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.539 by root, Tue May 4 22:49:21 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
… …
88our %EXT_CORO = (); # coroutines bound to extensions 87our %EXT_CORO = (); # coroutines bound to extensions
89our %EXT_MAP = (); # pluggable maps 88our %EXT_MAP = (); # pluggable maps
90 89
91our $RELOAD; # number of reloads so far, non-zero while in reload 90our $RELOAD; # number of reloads so far, non-zero while in reload
92our @EVENT; 91our @EVENT;
92our @REFLECT; # set by XS
93our %REFLECT; # set by us
93 94
94our $CONFDIR = confdir; 95our $CONFDIR = confdir;
95our $DATADIR = datadir; 96our $DATADIR = datadir;
96our $LIBDIR = "$DATADIR/ext"; 97our $LIBDIR = "$DATADIR/ext";
97our $PODDIR = "$DATADIR/pod"; 98our $PODDIR = "$DATADIR/pod";
… …
103our $RANDOMDIR = "$LOCALDIR/random"; 104our $RANDOMDIR = "$LOCALDIR/random";
104our $BDBDIR = "$LOCALDIR/db"; 105our $BDBDIR = "$LOCALDIR/db";
105our $PIDFILE = "$LOCALDIR/pid"; 106our $PIDFILE = "$LOCALDIR/pid";
106our $RUNTIMEFILE = "$LOCALDIR/runtime"; 107our $RUNTIMEFILE = "$LOCALDIR/runtime";
107 108
108our %RESOURCE; 109our %RESOURCE; # unused
110
111our $OUTPUT_RATE_MIN = 3000;
112our $OUTPUT_RATE_MAX = 1000000;
113
114our $MAX_LINKS = 32; # how many chained exits to follow
115our $VERBOSE_IO = 1;
109 116
110our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 117our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
111our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 118our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
112our $NEXT_TICK; 119our $NEXT_TICK;
113our $USE_FSYNC = 1; # use fsync to write maps - default on 120our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
115our $BDB_DEADLOCK_WATCHER; 122our $BDB_DEADLOCK_WATCHER;
116our $BDB_CHECKPOINT_WATCHER; 123our $BDB_CHECKPOINT_WATCHER;
117our $BDB_TRICKLE_WATCHER; 124our $BDB_TRICKLE_WATCHER;
118our $DB_ENV; 125our $DB_ENV;
119 126
120our @EXTRA_MODULES = qw(pod mapscript); 127our @EXTRA_MODULES = qw(pod match mapscript);
121 128
122our %CFG; 129our %CFG;
123 130
124our $UPTIME; $UPTIME ||= time; 131our $UPTIME; $UPTIME ||= time;
125our $RUNTIME; 132our $RUNTIME;
… …
159 166
160our $EMERGENCY_POSITION; 167our $EMERGENCY_POSITION;
161 168
162sub cf::map::normalise; 169sub cf::map::normalise;
163 170
171sub in_main() {
172 $Coro::current == $Coro::main
173}
174
175#############################################################################
176
177%REFLECT = ();
178for (@REFLECT) {
179 my $reflect = JSON::XS::decode_json $_;
180 $REFLECT{$reflect->{class}} = $reflect;
181}
182
183# this is decidedly evil
184$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
185
164############################################################################# 186#############################################################################
165 187
166=head2 GLOBAL VARIABLES 188=head2 GLOBAL VARIABLES
167 189
168=over 4 190=over 4
… …
214returns directly I<after> the tick processing (and consequently, can only wake one process 236returns directly I<after> the tick processing (and consequently, can only wake one process
215per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 237per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
216 238
217=item @cf::INVOKE_RESULTS 239=item @cf::INVOKE_RESULTS
218 240
219This array contains the results of the last C<invoke ()> call. When 241This 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 242C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
221that call. 243that call.
222 244
245=item %cf::REFLECT
246
247Contains, for each (C++) class name, a hash reference with information
248about object members (methods, scalars, arrays and flags) and other
249metadata, which is useful for introspection.
250
223=back 251=back
224 252
225=cut 253=cut
254
255sub error(@) { LOG llevError, join "", @_ }
256sub warn (@) { LOG llevWarn , join "", @_ }
257sub info (@) { LOG llevInfo , join "", @_ }
258sub debug(@) { LOG llevDebug, join "", @_ }
259sub trace(@) { LOG llevTrace, join "", @_ }
226 260
227$Coro::State::WARNHOOK = sub { 261$Coro::State::WARNHOOK = sub {
228 my $msg = join "", @_; 262 my $msg = join "", @_;
229 263
230 $msg .= "\n" 264 $msg .= "\n"
231 unless $msg =~ /\n$/; 265 unless $msg =~ /\n$/;
232 266
233 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 267 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
234 268
235 LOG llevError, $msg; 269 LOG llevWarn, $msg;
236}; 270};
237 271
238$Coro::State::DIEHOOK = sub { 272$Coro::State::DIEHOOK = sub {
239 return unless $^S eq 0; # "eq", not "==" 273 return unless $^S eq 0; # "eq", not "=="
240 274
241 warn Carp::longmess $_[0]; 275 error Carp::longmess $_[0];
242 276
243 if ($Coro::current == $Coro::main) {#d# 277 if (in_main) {#d#
244 warn "DIEHOOK called in main context, Coro bug?\n";#d# 278 error "DIEHOOK called in main context, Coro bug?\n";#d#
245 return;#d# 279 return;#d#
246 }#d# 280 }#d#
247 281
248 # kill coroutine otherwise 282 # kill coroutine otherwise
249 Coro::terminate 283 Coro::terminate
… …
269)) { 303)) {
270 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 304 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
271} 305}
272 306
273$EV::DIED = sub { 307$EV::DIED = sub {
274 warn "error in event callback: @_"; 308 Carp::cluck "error in event callback: @_";
275}; 309};
276 310
277############################################################################# 311#############################################################################
278 312
279=head2 UTILITY FUNCTIONS 313=head2 UTILITY FUNCTIONS
… …
376} 410}
377 411
378=item cf::periodic $interval, $cb 412=item cf::periodic $interval, $cb
379 413
380Like EV::periodic, but randomly selects a starting point so that the actions 414Like EV::periodic, but randomly selects a starting point so that the actions
381get spread over timer. 415get spread over time.
382 416
383=cut 417=cut
384 418
385sub periodic($$) { 419sub periodic($$) {
386 my ($interval, $cb) = @_; 420 my ($interval, $cb) = @_;
… …
403 437
404=cut 438=cut
405 439
406our @SLOT_QUEUE; 440our @SLOT_QUEUE;
407our $SLOT_QUEUE; 441our $SLOT_QUEUE;
442our $SLOT_DECAY = 0.9;
408 443
409$SLOT_QUEUE->cancel if $SLOT_QUEUE; 444$SLOT_QUEUE->cancel if $SLOT_QUEUE;
410$SLOT_QUEUE = Coro::async { 445$SLOT_QUEUE = Coro::async {
411 $Coro::current->desc ("timeslot manager"); 446 $Coro::current->desc ("timeslot manager");
412 447
413 my $signal = new Coro::Signal; 448 my $signal = new Coro::Signal;
449 my $busy;
414 450
415 while () { 451 while () {
416 next_job: 452 next_job:
453
417 my $avail = cf::till_tick; 454 my $avail = cf::till_tick;
418 if ($avail > 0.01) { 455
419 for (0 .. $#SLOT_QUEUE) { 456 for (0 .. $#SLOT_QUEUE) {
420 if ($SLOT_QUEUE[$_][0] < $avail) { 457 if ($SLOT_QUEUE[$_][0] <= $avail) {
458 $busy = 0;
421 my $job = splice @SLOT_QUEUE, $_, 1, (); 459 my $job = splice @SLOT_QUEUE, $_, 1, ();
422 $job->[2]->send; 460 $job->[2]->send;
423 Coro::cede; 461 Coro::cede;
424 goto next_job; 462 goto next_job;
425 } 463 } else {
464 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
426 } 465 }
427 } 466 }
428 467
429 if (@SLOT_QUEUE) { 468 if (@SLOT_QUEUE) {
430 # we do not use wait_for_tick() as it returns immediately when tick is inactive 469 # we do not use wait_for_tick() as it returns immediately when tick is inactive
431 push @cf::WAIT_FOR_TICK, $signal; 470 push @cf::WAIT_FOR_TICK, $signal;
432 $signal->wait; 471 $signal->wait;
433 } else { 472 } else {
473 $busy = 0;
434 Coro::schedule; 474 Coro::schedule;
435 } 475 }
436 } 476 }
437}; 477};
438 478
439sub get_slot($;$$) { 479sub get_slot($;$$) {
440 return if tick_inhibit || $Coro::current == $Coro::main; 480 return if tick_inhibit || $Coro::current == $Coro::main;
441 481
442 my ($time, $pri, $name) = @_; 482 my ($time, $pri, $name) = @_;
443 483
444 $time = $TICK * .6 if $time > $TICK * .6; 484 $time = clamp $time, 0.01, $TICK * .6;
485
445 my $sig = new Coro::Signal; 486 my $sig = new Coro::Signal;
446 487
447 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 488 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
448 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 489 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
449 $SLOT_QUEUE->ready; 490 $SLOT_QUEUE->ready;
… …
475=cut 516=cut
476 517
477sub sync_job(&) { 518sub sync_job(&) {
478 my ($job) = @_; 519 my ($job) = @_;
479 520
480 if ($Coro::current == $Coro::main) { 521 if (in_main) {
481 my $time = EV::time; 522 my $time = AE::time;
482 523
483 # this is the main coro, too bad, we have to block 524 # this is the main coro, too bad, we have to block
484 # till the operation succeeds, freezing the server :/ 525 # till the operation succeeds, freezing the server :/
485 526
486 LOG llevError, Carp::longmess "sync job";#d# 527 #LOG llevError, Carp::longmess "sync job";#d#
487 528
488 my $freeze_guard = freeze_mainloop; 529 my $freeze_guard = freeze_mainloop;
489 530
490 my $busy = 1; 531 my $busy = 1;
491 my @res; 532 my @res;
492 533
493 (async { 534 (async {
494 $Coro::current->desc ("sync job coro"); 535 $Coro::current->desc ("sync job coro");
495 @res = eval { $job->() }; 536 @res = eval { $job->() };
496 warn $@ if $@; 537 error $@ if $@;
497 undef $busy; 538 undef $busy;
498 })->prio (Coro::PRIO_MAX); 539 })->prio (Coro::PRIO_MAX);
499 540
500 while ($busy) { 541 while ($busy) {
501 if (Coro::nready) { 542 if (Coro::nready) {
… …
503 } else { 544 } else {
504 EV::loop EV::LOOP_ONESHOT; 545 EV::loop EV::LOOP_ONESHOT;
505 } 546 }
506 } 547 }
507 548
508 my $time = EV::time - $time; 549 my $time = AE::time - $time;
509 550
510 $TICK_START += $time; # do not account sync jobs to server load 551 $TICK_START += $time; # do not account sync jobs to server load
511 552
512 wantarray ? @res : $res[0] 553 wantarray ? @res : $res[0]
513 } else { 554 } else {
… …
557 reset_signals; 598 reset_signals;
558 &$cb 599 &$cb
559 }, @args; 600 }, @args;
560 601
561 wantarray ? @res : $res[-1] 602 wantarray ? @res : $res[-1]
603}
604
605sub objinfo {
606 (
607 "counter value" => cf::object::object_count,
608 "objects created" => cf::object::create_count,
609 "objects destroyed" => cf::object::destroy_count,
610 "freelist size" => cf::object::free_count,
611 "allocated objects" => cf::object::objects_size,
612 "active objects" => cf::object::actives_size,
613 )
562} 614}
563 615
564=item $coin = coin_from_name $name 616=item $coin = coin_from_name $name
565 617
566=cut 618=cut
… …
603within each server. 655within each server.
604 656
605=cut 657=cut
606 658
607sub db_table($) { 659sub db_table($) {
660 cf::error "db_get called from main context"
661 if $Coro::current == $Coro::main;
662
608 my ($name) = @_; 663 my ($name) = @_;
609 my $db = BDB::db_create $DB_ENV; 664 my $db = BDB::db_create $DB_ENV;
610 665
611 eval { 666 eval {
612 $db->set_flags (BDB::CHKSUM); 667 $db->set_flags (BDB::CHKSUM);
… …
622} 677}
623 678
624our $DB; 679our $DB;
625 680
626sub db_init { 681sub db_init {
627 cf::sync_job {
628 $DB ||= db_table "db"; 682 $DB ||= db_table "db";
629 };
630} 683}
631 684
632sub db_get($$) { 685sub db_get($$) {
633 my $key = "$_[0]/$_[1]"; 686 my $key = "$_[0]/$_[1]";
634 687
635 cf::sync_job { 688 cf::error "db_get called from main context"
689 if $Coro::current == $Coro::main;
690
636 BDB::db_get $DB, undef, $key, my $data; 691 BDB::db_get $DB, undef, $key, my $data;
637 692
638 $! ? () 693 $! ? ()
639 : $data 694 : $data
640 }
641} 695}
642 696
643sub db_put($$$) { 697sub db_put($$$) {
644 BDB::dbreq_pri 4; 698 BDB::dbreq_pri 4;
645 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 699 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
701 755
702 my $t1 = Time::HiRes::time; 756 my $t1 = Time::HiRes::time;
703 my $data = $process->(\@data); 757 my $data = $process->(\@data);
704 my $t2 = Time::HiRes::time; 758 my $t2 = Time::HiRes::time;
705 759
706 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 760 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
707 761
708 db_put cache => "$id/data", $data; 762 db_put cache => "$id/data", $data;
709 db_put cache => "$id/md5" , $md5; 763 db_put cache => "$id/md5" , $md5;
710 db_put cache => "$id/meta", $meta; 764 db_put cache => "$id/meta", $meta;
711 765
… …
721 775
722=cut 776=cut
723 777
724sub datalog($@) { 778sub datalog($@) {
725 my ($type, %kv) = @_; 779 my ($type, %kv) = @_;
726 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 780 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
727} 781}
728 782
729=back 783=back
730 784
731=cut 785=cut
… …
926 980
927 } elsif (exists $cb_id{$type}) { 981 } elsif (exists $cb_id{$type}) {
928 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 982 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
929 983
930 } elsif (ref $type) { 984 } elsif (ref $type) {
931 warn "attaching objects not supported, ignoring.\n"; 985 error "attaching objects not supported, ignoring.\n";
932 986
933 } else { 987 } else {
934 shift @arg; 988 shift @arg;
935 warn "attach argument '$type' not supported, ignoring.\n"; 989 error "attach argument '$type' not supported, ignoring.\n";
936 } 990 }
937 } 991 }
938} 992}
939 993
940sub _object_attach { 994sub _object_attach {
… …
950 _attach $registry, $klass, @attach; 1004 _attach $registry, $klass, @attach;
951 } 1005 }
952 1006
953 $obj->{$name} = \%arg; 1007 $obj->{$name} = \%arg;
954 } else { 1008 } else {
955 warn "object uses attachment '$name' which is not available, postponing.\n"; 1009 info "object uses attachment '$name' which is not available, postponing.\n";
956 } 1010 }
957 1011
958 $obj->{_attachment}{$name} = undef; 1012 $obj->{_attachment}{$name} = undef;
959} 1013}
960 1014
… …
1019 1073
1020 for (@$callbacks) { 1074 for (@$callbacks) {
1021 eval { &{$_->[1]} }; 1075 eval { &{$_->[1]} };
1022 1076
1023 if ($@) { 1077 if ($@) {
1024 warn "$@";
1025 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1078 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1026 override; 1079 override;
1027 } 1080 }
1028 1081
1029 return 1 if $override; 1082 return 1 if $override;
1030 } 1083 }
… …
1109 for (@$attach) { 1162 for (@$attach) {
1110 my ($klass, @attach) = @$_; 1163 my ($klass, @attach) = @$_;
1111 _attach $registry, $klass, @attach; 1164 _attach $registry, $klass, @attach;
1112 } 1165 }
1113 } else { 1166 } else {
1114 warn "object uses attachment '$name' that is not available, postponing.\n"; 1167 info "object uses attachment '$name' that is not available, postponing.\n";
1115 } 1168 }
1116 } 1169 }
1117} 1170}
1118 1171
1119cf::attachable->attach ( 1172cf::attachable->attach (
… …
1146 my ($filename, $rdata, $objs) = @_; 1199 my ($filename, $rdata, $objs) = @_;
1147 1200
1148 sync_job { 1201 sync_job {
1149 if (length $$rdata) { 1202 if (length $$rdata) {
1150 utf8::decode (my $decname = $filename); 1203 utf8::decode (my $decname = $filename);
1151 warn sprintf "saving %s (%d,%d)\n", 1204 trace sprintf "saving %s (%d,%d)\n",
1152 $decname, length $$rdata, scalar @$objs; 1205 $decname, length $$rdata, scalar @$objs
1206 if $VERBOSE_IO;
1153 1207
1154 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1208 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1155 aio_chmod $fh, SAVE_MODE; 1209 aio_chmod $fh, SAVE_MODE;
1156 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1210 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1157 if ($cf::USE_FSYNC) { 1211 if ($cf::USE_FSYNC) {
… …
1179 aio_rename "$filename~", $filename; 1233 aio_rename "$filename~", $filename;
1180 1234
1181 $filename =~ s%/[^/]+$%%; 1235 $filename =~ s%/[^/]+$%%;
1182 aio_pathsync $filename if $cf::USE_FSYNC; 1236 aio_pathsync $filename if $cf::USE_FSYNC;
1183 } else { 1237 } else {
1184 warn "unable to save objects: $filename~: $!\n"; 1238 error "unable to save objects: $filename~: $!\n";
1185 } 1239 }
1186 } else { 1240 } else {
1187 aio_unlink $filename; 1241 aio_unlink $filename;
1188 aio_unlink "$filename.pst"; 1242 aio_unlink "$filename.pst";
1189 } 1243 }
… …
1213 my $st = eval { Coro::Storable::thaw $av }; 1267 my $st = eval { Coro::Storable::thaw $av };
1214 $av = $st->{objs}; 1268 $av = $st->{objs};
1215 } 1269 }
1216 1270
1217 utf8::decode (my $decname = $filename); 1271 utf8::decode (my $decname = $filename);
1218 warn sprintf "loading %s (%d,%d)\n", 1272 trace sprintf "loading %s (%d,%d)\n",
1219 $decname, length $data, scalar @{$av || []}; 1273 $decname, length $data, scalar @{$av || []}
1274 if $VERBOSE_IO;
1220 1275
1221 ($data, $av) 1276 ($data, $av)
1222} 1277}
1223 1278
1224=head2 COMMAND CALLBACKS 1279=head2 COMMAND CALLBACKS
… …
1283} 1338}
1284 1339
1285use File::Glob (); 1340use File::Glob ();
1286 1341
1287cf::player->attach ( 1342cf::player->attach (
1288 on_command => sub { 1343 on_unknown_command => sub {
1289 my ($pl, $name, $params) = @_; 1344 my ($pl, $name, $params) = @_;
1290 1345
1291 my $cb = $COMMAND{$name} 1346 my $cb = $COMMAND{$name}
1292 or return; 1347 or return;
1293 1348
… …
1316 1371
1317 $pl->ext_reply ($reply, @reply) 1372 $pl->ext_reply ($reply, @reply)
1318 if $reply; 1373 if $reply;
1319 1374
1320 } else { 1375 } else {
1321 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1376 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1322 } 1377 }
1323 1378
1324 cf::override; 1379 cf::override;
1325 }, 1380 },
1326); 1381);
… …
1337 1392
1338 $grp 1393 $grp
1339} 1394}
1340 1395
1341sub load_extensions { 1396sub load_extensions {
1397 info "loading extensions...";
1398
1342 cf::sync_job { 1399 cf::sync_job {
1343 my %todo; 1400 my %todo;
1344 1401
1345 for my $path (<$LIBDIR/*.ext>) { 1402 for my $path (<$LIBDIR/*.ext>) {
1346 next unless -r $path; 1403 next unless -r $path;
… …
1364 1421
1365 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1422 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1366 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1423 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1367 1424
1368 $ext{source} = 1425 $ext{source} =
1369 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1426 "package $pkg; use common::sense;\n"
1370 . "#line 1 \"$path\"\n{\n" 1427 . "#line 1 \"$path\"\n{\n"
1371 . $source 1428 . $source
1372 . "\n};\n1"; 1429 . "\n};\n1";
1373 1430
1374 $todo{$base} = \%ext; 1431 $todo{$base} = \%ext;
1375 } 1432 }
1376 1433
1434 my $pass = 0;
1377 my %done; 1435 my %done;
1378 while (%todo) { 1436 while (%todo) {
1379 my $progress; 1437 my $progress;
1380 1438
1439 ++$pass;
1440
1441 ext:
1381 while (my ($k, $v) = each %todo) { 1442 while (my ($k, $v) = each %todo) {
1382 for (split /,\s*/, $v->{meta}{depends}) { 1443 for (split /,\s*/, $v->{meta}{depends}) {
1383 goto skip 1444 next ext
1384 unless exists $done{$_}; 1445 unless exists $done{$_};
1385 } 1446 }
1386 1447
1387 warn "... loading '$k' into '$v->{pkg}'\n"; 1448 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1388 1449
1389 unless (eval $v->{source}) { 1450 my $active = eval $v->{source};
1451
1452 if (length $@) {
1390 my $msg = $@ ? "$v->{path}: $@\n" 1453 error "$v->{path}: $@\n";
1391 : "$v->{base}: extension inactive.\n"; 1454 undef $@; # work around perl 5.10.0 utf-8 caching bug
1392 1455
1393 if (exists $v->{meta}{mandatory}) {
1394 warn $msg;
1395 cf::cleanup "mandatory extension failed to load, exiting."; 1456 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1396 } 1457 if exists $v->{meta}{mandatory};
1397 1458
1398 warn $msg; 1459 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1460 delete $todo{$k};
1461 } else {
1462 $done{$k} = delete $todo{$k};
1463 push @EXTS, $v->{pkg};
1464 $progress = 1;
1465
1466 info "$v->{base}: extension inactive.\n"
1467 unless $active;
1399 } 1468 }
1400
1401 $done{$k} = delete $todo{$k};
1402 push @EXTS, $v->{pkg};
1403 $progress = 1;
1404 } 1469 }
1405 1470
1406 skip: 1471 unless ($progress) {
1407 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1472 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1408 unless $progress; 1473
1474 while (my ($k, $v) = each %todo) {
1475 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1476 if exists $v->{meta}{mandatory};
1477 }
1478 }
1409 } 1479 }
1410 }; 1480 };
1411} 1481}
1412 1482
1413############################################################################# 1483#############################################################################
… …
1497 $cf::PLAYER{$login} = $pl 1567 $cf::PLAYER{$login} = $pl
1498 } 1568 }
1499 } 1569 }
1500} 1570}
1501 1571
1572cf::player->attach (
1573 on_load => sub {
1574 my ($pl, $path) = @_;
1575
1576 # restore slots saved in save, below
1577 my $slots = delete $pl->{_slots};
1578
1579 $pl->ob->current_weapon ($slots->[0]);
1580 $pl->combat_ob ($slots->[1]);
1581 $pl->ranged_ob ($slots->[2]);
1582 },
1583);
1584
1502sub save($) { 1585sub save($) {
1503 my ($pl) = @_; 1586 my ($pl) = @_;
1504 1587
1505 return if $pl->{deny_save}; 1588 return if $pl->{deny_save};
1506 1589
… …
1511 1594
1512 aio_mkdir playerdir $pl, 0770; 1595 aio_mkdir playerdir $pl, 0770;
1513 $pl->{last_save} = $cf::RUNTIME; 1596 $pl->{last_save} = $cf::RUNTIME;
1514 1597
1515 cf::get_slot 0.01; 1598 cf::get_slot 0.01;
1599
1600 # save slots, to be restored later
1601 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1516 1602
1517 $pl->save_pl ($path); 1603 $pl->save_pl ($path);
1518 cf::cede_to_tick; 1604 cf::cede_to_tick;
1519} 1605}
1520 1606
… …
1557 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1643 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1558 1644
1559 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1645 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1560 $pl->deactivate; 1646 $pl->deactivate;
1561 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1647 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1562 $pl->ob->check_score;
1563 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1648 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1564 $pl->ns->destroy if $pl->ns; 1649 $pl->ns->destroy if $pl->ns;
1565 1650
1566 my $path = playerdir $pl; 1651 my $path = playerdir $pl;
1567 my $temp = "$path~$cf::RUNTIME~deleting~"; 1652 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1622 \@logins 1707 \@logins
1623} 1708}
1624 1709
1625=item $player->maps 1710=item $player->maps
1626 1711
1712=item cf::player::maps $login
1713
1627Returns an arrayref of map paths that are private for this 1714Returns an arrayref of map paths that are private for this
1628player. May block. 1715player. May block.
1629 1716
1630=cut 1717=cut
1631 1718
… …
1693=cut 1780=cut
1694 1781
1695sub find_by_path($) { 1782sub find_by_path($) {
1696 my ($path) = @_; 1783 my ($path) = @_;
1697 1784
1785 $path =~ s/^~[^\/]*//; # skip ~login
1786
1698 my ($match, $specificity); 1787 my ($match, $specificity);
1699 1788
1700 for my $region (list) { 1789 for my $region (list) {
1701 if ($region->{match} && $path =~ $region->{match}) { 1790 if ($region->{match} && $path =~ $region->{match}) {
1702 ($match, $specificity) = ($region, $region->specificity) 1791 ($match, $specificity) = ($region, $region->specificity)
… …
1733 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1822 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1734 1823
1735 # mit "rum" bekleckern, nicht 1824 # mit "rum" bekleckern, nicht
1736 $self->_create_random_map ( 1825 $self->_create_random_map (
1737 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1826 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1738 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1827 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1739 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1828 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1740 $rmp->{exit_on_final_map}, 1829 $rmp->{exit_on_final_map},
1741 $rmp->{xsize}, $rmp->{ysize}, 1830 $rmp->{xsize}, $rmp->{ysize},
1742 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1831 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1743 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1832 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1758 1847
1759sub register { 1848sub register {
1760 my (undef, $regex, $prio) = @_; 1849 my (undef, $regex, $prio) = @_;
1761 my $pkg = caller; 1850 my $pkg = caller;
1762 1851
1763 no strict;
1764 push @{"$pkg\::ISA"}, __PACKAGE__; 1852 push @{"$pkg\::ISA"}, __PACKAGE__;
1765 1853
1766 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1854 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1767} 1855}
1768 1856
1769# also paths starting with '/' 1857# also paths starting with '/'
1770$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1858$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1771 1859
1772sub thawer_merge { 1860sub thawer_merge {
1773 my ($self, $merge) = @_; 1861 my ($self, $merge) = @_;
1774 1862
1775 # we have to keep some variables in memory intact 1863 # we have to keep some variables in memory intact
… …
1989 2077
1990 $cf::MAP{$path} = $map 2078 $cf::MAP{$path} = $map
1991 } 2079 }
1992} 2080}
1993 2081
1994sub pre_load { } 2082sub pre_load { }
1995sub post_load { } 2083#sub post_load { } # XS
1996 2084
1997sub load { 2085sub load {
1998 my ($self) = @_; 2086 my ($self) = @_;
1999 2087
2000 local $self->{deny_reset} = 1; # loading can take a long time 2088 local $self->{deny_reset} = 1; # loading can take a long time
… …
2057 } 2145 }
2058 2146
2059 $self->post_load; 2147 $self->post_load;
2060} 2148}
2061 2149
2150# customize the map for a given player, i.e.
2151# return the _real_ map. used by e.g. per-player
2152# maps to change the path to ~playername/mappath
2062sub customise_for { 2153sub customise_for {
2063 my ($self, $ob) = @_; 2154 my ($self, $ob) = @_;
2064 2155
2065 return find "~" . $ob->name . "/" . $self->{path} 2156 return find "~" . $ob->name . "/" . $self->{path}
2066 if $self->per_player; 2157 if $self->per_player;
… …
2082 or next; 2173 or next;
2083 $neigh = find $neigh, $map 2174 $neigh = find $neigh, $map
2084 or next; 2175 or next;
2085 $neigh->load; 2176 $neigh->load;
2086 2177
2178 # now find the diagonal neighbours
2087 push @neigh, 2179 push @neigh,
2088 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2180 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2089 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2181 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2090 } 2182 }
2091 2183
… …
2098} 2190}
2099 2191
2100sub find_sync { 2192sub find_sync {
2101 my ($path, $origin) = @_; 2193 my ($path, $origin) = @_;
2102 2194
2103 cf::sync_job { find $path, $origin } 2195 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2196 if $Coro::current == $Coro::main;
2197
2198 find $path, $origin
2104} 2199}
2105 2200
2106sub do_load_sync { 2201sub do_load_sync {
2107 my ($map) = @_; 2202 my ($map) = @_;
2108 2203
2109 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2204 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2110 if $Coro::current == $Coro::main; 2205 if $Coro::current == $Coro::main;
2111 2206
2112 cf::sync_job { $map->load }; 2207 $map->load;
2113} 2208}
2114 2209
2115our %MAP_PREFETCH; 2210our %MAP_PREFETCH;
2116our $MAP_PREFETCHER = undef; 2211our $MAP_PREFETCHER = undef;
2117 2212
… …
2143 $MAP_PREFETCHER->prio (6); 2238 $MAP_PREFETCHER->prio (6);
2144 2239
2145 () 2240 ()
2146} 2241}
2147 2242
2243# common code, used by both ->save and ->swapout
2148sub save { 2244sub _save {
2149 my ($self) = @_; 2245 my ($self) = @_;
2150
2151 my $lock = cf::lock_acquire "map_data:$self->{path}";
2152 2246
2153 $self->{last_save} = $cf::RUNTIME; 2247 $self->{last_save} = $cf::RUNTIME;
2154 2248
2155 return unless $self->dirty; 2249 return unless $self->dirty;
2156 2250
… …
2176 } else { 2270 } else {
2177 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2271 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2178 } 2272 }
2179} 2273}
2180 2274
2275sub save {
2276 my ($self) = @_;
2277
2278 my $lock = cf::lock_acquire "map_data:$self->{path}";
2279
2280 $self->_save;
2281}
2282
2181sub swap_out { 2283sub swap_out {
2182 my ($self) = @_; 2284 my ($self) = @_;
2183 2285
2184 # save first because save cedes
2185 $self->save;
2186
2187 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2286 my $lock = cf::lock_acquire "map_data:$self->{path}";
2188 2287
2189 return if $self->players;
2190 return if $self->in_memory != cf::MAP_ACTIVE; 2288 return if $self->in_memory != cf::MAP_ACTIVE;
2191 return if $self->{deny_save}; 2289 return if $self->{deny_save};
2290 return if $self->players;
2192 2291
2292 # first deactivate the map and "unlink" it from the core
2293 $self->deactivate;
2294 $_->clear_links_to ($self) for values %cf::MAP;
2193 $self->in_memory (cf::MAP_SWAPPED); 2295 $self->in_memory (cf::MAP_SWAPPED);
2296
2297 # then atomically save
2298 $self->_save;
2299
2300 # then free the map
2301 $self->clear;
2302}
2303
2304sub reset_at {
2305 my ($self) = @_;
2306
2307 # TODO: safety, remove and allow resettable per-player maps
2308 return 1e99 if $self->{deny_reset};
2309
2310 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2311 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2312
2313 $time + $to
2314}
2315
2316sub should_reset {
2317 my ($self) = @_;
2318
2319 $self->reset_at <= $cf::RUNTIME
2320}
2321
2322sub reset {
2323 my ($self) = @_;
2324
2325 my $lock = cf::lock_acquire "map_data:$self->{path}";
2326
2327 return if $self->players;
2328
2329 cf::trace "resetting map ", $self->path, "\n";
2330
2331 $self->in_memory (cf::MAP_SWAPPED);
2332
2333 # need to save uniques path
2334 unless ($self->{deny_save}) {
2335 my $uniq = $self->uniq_path; utf8::encode $uniq;
2336
2337 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2338 if $uniq;
2339 }
2340
2341 delete $cf::MAP{$self->path};
2194 2342
2195 $self->deactivate; 2343 $self->deactivate;
2196 $_->clear_links_to ($self) for values %cf::MAP; 2344 $_->clear_links_to ($self) for values %cf::MAP;
2197 $self->clear; 2345 $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 2346
2243 $self->unlink_save; 2347 $self->unlink_save;
2244 $self->destroy; 2348 $self->destroy;
2245} 2349}
2246 2350
… …
2254 2358
2255 delete $cf::MAP{$self->path}; 2359 delete $cf::MAP{$self->path};
2256 2360
2257 $self->unlink_save; 2361 $self->unlink_save;
2258 2362
2259 bless $self, "cf::map"; 2363 bless $self, "cf::map::wrap";
2260 delete $self->{deny_reset}; 2364 delete $self->{deny_reset};
2261 $self->{deny_save} = 1; 2365 $self->{deny_save} = 1;
2262 $self->reset_timeout (1); 2366 $self->reset_timeout (1);
2263 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2367 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2264 2368
… …
2321 : normalise $_ 2425 : normalise $_
2322 } @{ aio_readdir $UNIQUEDIR or [] } 2426 } @{ aio_readdir $UNIQUEDIR or [] }
2323 ] 2427 ]
2324} 2428}
2325 2429
2430=item cf::map::static_maps
2431
2432Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2433file in the shared directory excluding F</styles> and F</editor>). May
2434block.
2435
2436=cut
2437
2438sub static_maps() {
2439 my @dirs = "";
2440 my @maps;
2441
2442 while (@dirs) {
2443 my $dir = shift @dirs;
2444
2445 next if $dir eq "/styles" || $dir eq "/editor";
2446
2447 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2448 or return;
2449
2450 for (@$files) {
2451 s/\.map$// or next;
2452 utf8::decode $_;
2453 push @maps, "$dir/$_";
2454 }
2455
2456 push @dirs, map "$dir/$_", @$dirs;
2457 }
2458
2459 \@maps
2460}
2461
2326=back 2462=back
2327 2463
2328=head3 cf::object 2464=head3 cf::object
2329 2465
2330=cut 2466=cut
… …
2462 2598
2463Freezes the player and moves him/her to a special map (C<{link}>). 2599Freezes the player and moves him/her to a special map (C<{link}>).
2464 2600
2465The player should be reasonably safe there for short amounts of time (e.g. 2601The 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, 2602for 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 2603though, as the player cannot control the character while it is on the link
2468map. 2604map.
2469 2605
2470Will never block. 2606Will never block.
2471 2607
2472=item $player_object->leave_link ($map, $x, $y) 2608=item $player_object->leave_link ($map, $x, $y)
… …
2493sub cf::object::player::enter_link { 2629sub cf::object::player::enter_link {
2494 my ($self) = @_; 2630 my ($self) = @_;
2495 2631
2496 $self->deactivate_recursive; 2632 $self->deactivate_recursive;
2497 2633
2634 ++$self->{_link_recursion};
2635
2498 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2636 return if UNIVERSAL::isa $self->map, "ext::map_link";
2499 2637
2500 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2638 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2501 if $self->map && $self->map->{path} ne "{link}"; 2639 if $self->map && $self->map->{path} ne "{link}";
2502 2640
2503 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2641 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2504} 2642}
2505 2643
2506sub cf::object::player::leave_link { 2644sub cf::object::player::leave_link {
2507 my ($self, $map, $x, $y) = @_; 2645 my ($self, $map, $x, $y) = @_;
2508 2646
… …
2525 ($x, $y) = (-1, -1) 2663 ($x, $y) = (-1, -1)
2526 unless (defined $x) && (defined $y); 2664 unless (defined $x) && (defined $y);
2527 2665
2528 # use -1 or undef as default coordinates, not 0, 0 2666 # use -1 or undef as default coordinates, not 0, 0
2529 ($x, $y) = ($map->enter_x, $map->enter_y) 2667 ($x, $y) = ($map->enter_x, $map->enter_y)
2530 if $x <=0 && $y <= 0; 2668 if $x <= 0 && $y <= 0;
2531 2669
2532 $map->load; 2670 $map->load;
2533 $map->load_neighbours; 2671 $map->load_neighbours;
2534 2672
2535 return unless $self->contr->active; 2673 return unless $self->contr->active;
2536 2674
2537 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2675 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2538 $self->enter_map ($map, $x, $y); 2676 if ($self->enter_map ($map, $x, $y)) {
2539 2677 # entering was successful
2678 delete $self->{_link_recursion};
2540 # only activate afterwards, to support waiting in hooks 2679 # only activate afterwards, to support waiting in hooks
2541 $self->activate_recursive; 2680 $self->activate_recursive;
2542} 2681 }
2543 2682
2683}
2684
2544=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2685=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2545 2686
2546Moves the player to the given map-path and coordinates by first freezing 2687Moves the player to the given map-path and coordinates by first freezing
2547her, loading and preparing them map, calling the provided $check callback 2688her, loading and preparing them map, calling the provided $check callback
2548that has to return the map if sucecssful, and then unfreezes the player on 2689that 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 2690the new (success) or old (failed) map position. In either case, $done will
… …
2556 2697
2557our $GOTOGEN; 2698our $GOTOGEN;
2558 2699
2559sub cf::object::player::goto { 2700sub cf::object::player::goto {
2560 my ($self, $path, $x, $y, $check, $done) = @_; 2701 my ($self, $path, $x, $y, $check, $done) = @_;
2702
2703 if ($self->{_link_recursion} >= $MAX_LINKS) {
2704 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2705 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2706 ($path, $x, $y) = @$EMERGENCY_POSITION;
2707 }
2561 2708
2562 # do generation counting so two concurrent goto's will be executed in-order 2709 # do generation counting so two concurrent goto's will be executed in-order
2563 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2710 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2564 2711
2565 $self->enter_link; 2712 $self->enter_link;
… …
2589 my $map = eval { 2736 my $map = eval {
2590 my $map = defined $path ? cf::map::find $path : undef; 2737 my $map = defined $path ? cf::map::find $path : undef;
2591 2738
2592 if ($map) { 2739 if ($map) {
2593 $map = $map->customise_for ($self); 2740 $map = $map->customise_for ($self);
2594 $map = $check->($map) if $check && $map; 2741 $map = $check->($map, $x, $y, $self) if $check && $map;
2595 } else { 2742 } else {
2596 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2743 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2597 } 2744 }
2598 2745
2599 $map 2746 $map
… …
2607 if ($gen == $self->{_goto_generation}) { 2754 if ($gen == $self->{_goto_generation}) {
2608 delete $self->{_goto_generation}; 2755 delete $self->{_goto_generation};
2609 $self->leave_link ($map, $x, $y); 2756 $self->leave_link ($map, $x, $y);
2610 } 2757 }
2611 2758
2612 $done->() if $done; 2759 $done->($self) if $done;
2613 })->prio (1); 2760 })->prio (1);
2614} 2761}
2615 2762
2616=item $player_object->enter_exit ($exit_object) 2763=item $player_object->enter_exit ($exit_object)
2617 2764
… …
2710 $self->message ("Something went wrong deep within the deliantra server. " 2857 $self->message ("Something went wrong deep within the deliantra server. "
2711 . "I'll try to bring you back to the map you were before. " 2858 . "I'll try to bring you back to the map you were before. "
2712 . "Please report this to the dungeon master!", 2859 . "Please report this to the dungeon master!",
2713 cf::NDI_UNIQUE | cf::NDI_RED); 2860 cf::NDI_UNIQUE | cf::NDI_RED);
2714 2861
2715 warn "ERROR in enter_exit: $@"; 2862 error "ERROR in enter_exit: $@";
2716 $self->leave_link; 2863 $self->leave_link;
2717 } 2864 }
2718 })->prio (1); 2865 })->prio (1);
2719} 2866}
2720 2867
… …
2732sub cf::client::send_drawinfo { 2879sub cf::client::send_drawinfo {
2733 my ($self, $text, $flags) = @_; 2880 my ($self, $text, $flags) = @_;
2734 2881
2735 utf8::encode $text; 2882 utf8::encode $text;
2736 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2883 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2884}
2885
2886=item $client->send_big_packet ($pkt)
2887
2888Like C<send_packet>, but tries to compress large packets, and fragments
2889them as required.
2890
2891=cut
2892
2893our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2894
2895sub cf::client::send_big_packet {
2896 my ($self, $pkt) = @_;
2897
2898 # try lzf for large packets
2899 $pkt = "lzf " . Compress::LZF::compress $pkt
2900 if 1024 <= length $pkt and $self->{can_lzf};
2901
2902 # split very large packets
2903 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2904 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2905 $pkt = "frag";
2906 }
2907
2908 $self->send_packet ($pkt);
2737} 2909}
2738 2910
2739=item $client->send_msg ($channel, $msg, $color, [extra...]) 2911=item $client->send_msg ($channel, $msg, $color, [extra...])
2740 2912
2741Send a drawinfo or msg packet to the client, formatting the msg for the 2913Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2745 2917
2746=cut 2918=cut
2747 2919
2748# non-persistent channels (usually the info channel) 2920# non-persistent channels (usually the info channel)
2749our %CHANNEL = ( 2921our %CHANNEL = (
2922 "c/motd" => {
2923 id => "infobox",
2924 title => "MOTD",
2925 reply => undef,
2926 tooltip => "The message of the day",
2927 },
2750 "c/identify" => { 2928 "c/identify" => {
2751 id => "infobox", 2929 id => "infobox",
2752 title => "Identify", 2930 title => "Identify",
2753 reply => undef, 2931 reply => undef,
2754 tooltip => "Items recently identified", 2932 tooltip => "Items recently identified",
… …
2756 "c/examine" => { 2934 "c/examine" => {
2757 id => "infobox", 2935 id => "infobox",
2758 title => "Examine", 2936 title => "Examine",
2759 reply => undef, 2937 reply => undef,
2760 tooltip => "Signs and other items you examined", 2938 tooltip => "Signs and other items you examined",
2939 },
2940 "c/shopinfo" => {
2941 id => "infobox",
2942 title => "Shop Info",
2943 reply => undef,
2944 tooltip => "What your bargaining skill tells you about the shop",
2761 }, 2945 },
2762 "c/book" => { 2946 "c/book" => {
2763 id => "infobox", 2947 id => "infobox",
2764 title => "Book", 2948 title => "Book",
2765 reply => undef, 2949 reply => undef,
… …
2881 my $pkt = "msg " 3065 my $pkt = "msg "
2882 . $self->{json_coder}->encode ( 3066 . $self->{json_coder}->encode (
2883 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3067 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2884 ); 3068 );
2885 3069
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); 3070 $self->send_big_packet ($pkt);
2897} 3071}
2898 3072
2899=item $client->ext_msg ($type, @msg) 3073=item $client->ext_msg ($type, @msg)
2900 3074
2901Sends an ext event to the client. 3075Sends an ext event to the client.
… …
2904 3078
2905sub cf::client::ext_msg($$@) { 3079sub cf::client::ext_msg($$@) {
2906 my ($self, $type, @msg) = @_; 3080 my ($self, $type, @msg) = @_;
2907 3081
2908 if ($self->extcmd == 2) { 3082 if ($self->extcmd == 2) {
2909 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3083 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2910 } elsif ($self->extcmd == 1) { # TODO: remove 3084 } elsif ($self->extcmd == 1) { # TODO: remove
2911 push @msg, msgtype => "event_$type"; 3085 push @msg, msgtype => "event_$type";
2912 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3086 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2913 } 3087 }
2914} 3088}
2915 3089
2916=item $client->ext_reply ($msgid, @msg) 3090=item $client->ext_reply ($msgid, @msg)
2917 3091
… …
2921 3095
2922sub cf::client::ext_reply($$@) { 3096sub cf::client::ext_reply($$@) {
2923 my ($self, $id, @msg) = @_; 3097 my ($self, $id, @msg) = @_;
2924 3098
2925 if ($self->extcmd == 2) { 3099 if ($self->extcmd == 2) {
2926 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3100 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2927 } elsif ($self->extcmd == 1) { 3101 } elsif ($self->extcmd == 1) {
2928 #TODO: version 1, remove 3102 #TODO: version 1, remove
2929 unshift @msg, msgtype => "reply", msgid => $id; 3103 unshift @msg, msgtype => "reply", msgid => $id;
2930 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3104 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2931 } 3105 }
2932} 3106}
2933 3107
2934=item $success = $client->query ($flags, "text", \&cb) 3108=item $success = $client->query ($flags, "text", \&cb)
2935 3109
… …
3006 3180
3007 $ns->ext_reply ($reply, @reply) 3181 $ns->ext_reply ($reply, @reply)
3008 if $reply; 3182 if $reply;
3009 3183
3010 } else { 3184 } else {
3011 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3185 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3012 } 3186 }
3013 3187
3014 cf::override; 3188 cf::override;
3015 }, 3189 },
3016); 3190);
… …
3036 3210
3037 $coro 3211 $coro
3038} 3212}
3039 3213
3040cf::client->attach ( 3214cf::client->attach (
3041 on_destroy => sub { 3215 on_client_destroy => sub {
3042 my ($ns) = @_; 3216 my ($ns) = @_;
3043 3217
3044 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3218 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3045 }, 3219 },
3046); 3220);
… …
3062our $safe_hole = new Safe::Hole; 3236our $safe_hole = new Safe::Hole;
3063 3237
3064$SIG{FPE} = 'IGNORE'; 3238$SIG{FPE} = 'IGNORE';
3065 3239
3066$safe->permit_only (Opcode::opset qw( 3240$safe->permit_only (Opcode::opset qw(
3067 :base_core :base_mem :base_orig :base_math 3241 :base_core :base_mem :base_orig :base_math :base_loop
3068 grepstart grepwhile mapstart mapwhile 3242 grepstart grepwhile mapstart mapwhile
3069 sort time 3243 sort time
3070)); 3244));
3071 3245
3072# here we export the classes and methods available to script code 3246# here we export the classes and methods available to script code
… …
3097 decrease split destroy change_exp value msg lore send_msg)], 3271 decrease split destroy change_exp value msg lore send_msg)],
3098 ["cf::object::player" => qw(player)], 3272 ["cf::object::player" => qw(player)],
3099 ["cf::player" => qw(peaceful send_msg)], 3273 ["cf::player" => qw(peaceful send_msg)],
3100 ["cf::map" => qw(trigger)], 3274 ["cf::map" => qw(trigger)],
3101) { 3275) {
3102 no strict 'refs';
3103 my ($pkg, @funs) = @$_; 3276 my ($pkg, @funs) = @$_;
3104 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3277 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3105 for @funs; 3278 for @funs;
3106} 3279}
3107 3280
… …
3124 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3297 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3125 $qcode =~ s/\n/\\n/g; 3298 $qcode =~ s/\n/\\n/g;
3126 3299
3127 %vars = (_dummy => 0) unless %vars; 3300 %vars = (_dummy => 0) unless %vars;
3128 3301
3302 my @res;
3129 local $_; 3303 local $_;
3130 local @safe::cf::_safe_eval_args = values %vars;
3131 3304
3132 my $eval = 3305 my $eval =
3133 "do {\n" 3306 "do {\n"
3134 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3307 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3135 . "#line 0 \"{$qcode}\"\n" 3308 . "#line 0 \"{$qcode}\"\n"
3136 . $code 3309 . $code
3137 . "\n}" 3310 . "\n}"
3138 ; 3311 ;
3139 3312
3313 if ($CFG{safe_eval}) {
3140 sub_generation_inc; 3314 sub_generation_inc;
3315 local @safe::cf::_safe_eval_args = values %vars;
3141 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3316 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3142 sub_generation_inc; 3317 sub_generation_inc;
3318 } else {
3319 local @cf::_safe_eval_args = values %vars;
3320 @res = wantarray ? eval eval : scalar eval $eval;
3321 }
3143 3322
3144 if ($@) { 3323 if ($@) {
3145 warn "$@"; 3324 warn "$@",
3146 warn "while executing safe code '$code'\n"; 3325 "while executing safe code '$code'\n",
3147 warn "with arguments " . (join " ", %vars) . "\n"; 3326 "with arguments " . (join " ", %vars) . "\n";
3148 } 3327 }
3149 3328
3150 wantarray ? @res : $res[0] 3329 wantarray ? @res : $res[0]
3151} 3330}
3152 3331
… …
3166=cut 3345=cut
3167 3346
3168sub register_script_function { 3347sub register_script_function {
3169 my ($fun, $cb) = @_; 3348 my ($fun, $cb) = @_;
3170 3349
3171 no strict 'refs'; 3350 $fun = "safe::$fun" if $CFG{safe_eval};
3172 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3351 *$fun = $safe_hole->wrap ($cb);
3173} 3352}
3174 3353
3175=back 3354=back
3176 3355
3177=cut 3356=cut
… …
3186 # for this (global event?) 3365 # for this (global event?)
3187 %ext::player_env::MUSIC_FACE_CACHE = (); 3366 %ext::player_env::MUSIC_FACE_CACHE = ();
3188 3367
3189 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3368 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3190 3369
3191 warn "loading facedata from $path\n"; 3370 trace "loading facedata from $path\n";
3192 3371
3193 my $facedata; 3372 my $facedata;
3194 0 < aio_load $path, $facedata 3373 0 < aio_load $path, $facedata
3195 or die "$path: $!"; 3374 or die "$path: $!";
3196 3375
… …
3198 3377
3199 $facedata->{version} == 2 3378 $facedata->{version} == 2
3200 or cf::cleanup "$path: version mismatch, cannot proceed."; 3379 or cf::cleanup "$path: version mismatch, cannot proceed.";
3201 3380
3202 # patch in the exptable 3381 # patch in the exptable
3382 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3203 $facedata->{resource}{"res/exp_table"} = { 3383 $facedata->{resource}{"res/exp_table"} = {
3204 type => FT_RSRC, 3384 type => FT_RSRC,
3205 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3385 data => $exp_table,
3386 hash => (Digest::MD5::md5 $exp_table),
3206 }; 3387 };
3207 cf::cede_to_tick; 3388 cf::cede_to_tick;
3208 3389
3209 { 3390 {
3210 my $faces = $facedata->{faceinfo}; 3391 my $faces = $facedata->{faceinfo};
… …
3212 while (my ($face, $info) = each %$faces) { 3393 while (my ($face, $info) = each %$faces) {
3213 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3394 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3214 3395
3215 cf::face::set_visibility $idx, $info->{visibility}; 3396 cf::face::set_visibility $idx, $info->{visibility};
3216 cf::face::set_magicmap $idx, $info->{magicmap}; 3397 cf::face::set_magicmap $idx, $info->{magicmap};
3217 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3398 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3218 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3399 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3219 3400
3220 cf::cede_to_tick; 3401 cf::cede_to_tick;
3221 } 3402 }
3222 3403
3223 while (my ($face, $info) = each %$faces) { 3404 while (my ($face, $info) = each %$faces) {
… …
3228 3409
3229 if (my $smooth = cf::face::find $info->{smooth}) { 3410 if (my $smooth = cf::face::find $info->{smooth}) {
3230 cf::face::set_smooth $idx, $smooth; 3411 cf::face::set_smooth $idx, $smooth;
3231 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3412 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3232 } else { 3413 } else {
3233 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3414 error "smooth face '$info->{smooth}' not found for face '$face'";
3234 } 3415 }
3235 3416
3236 cf::cede_to_tick; 3417 cf::cede_to_tick;
3237 } 3418 }
3238 } 3419 }
… …
3247 3428
3248 cf::anim::invalidate_all; # d'oh 3429 cf::anim::invalidate_all; # d'oh
3249 } 3430 }
3250 3431
3251 { 3432 {
3252 # TODO: for gcfclient pleasure, we should give resources
3253 # that gcfclient doesn't grok a >10000 face index.
3254 my $res = $facedata->{resource}; 3433 my $res = $facedata->{resource};
3255 3434
3256 while (my ($name, $info) = each %$res) { 3435 while (my ($name, $info) = each %$res) {
3257 if (defined $info->{type}) { 3436 if (defined $info->{type}) {
3258 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3437 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3259 my $data;
3260 3438
3261 if ($info->{type} & 1) { 3439 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}; 3440 cf::face::set_type $idx, $info->{type};
3276 } else { 3441 } else {
3277 $RESOURCE{$name} = $info; 3442 $RESOURCE{$name} = $info; # unused
3278 } 3443 }
3279 3444
3280 cf::cede_to_tick; 3445 cf::cede_to_tick;
3281 } 3446 }
3282 } 3447 }
3283 3448
3284 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3449 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3285 3450
3286 1 3451 1
3287} 3452}
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 3453
3309register_exticmd fx_want => sub { 3454register_exticmd fx_want => sub {
3310 my ($ns, $want) = @_; 3455 my ($ns, $want) = @_;
3311 3456
3312 while (my ($k, $v) = each %$want) { 3457 while (my ($k, $v) = each %$want) {
… …
3351sub reload_treasures { 3496sub reload_treasures {
3352 load_resource_file "$DATADIR/treasures" 3497 load_resource_file "$DATADIR/treasures"
3353 or die "unable to load treasurelists\n"; 3498 or die "unable to load treasurelists\n";
3354} 3499}
3355 3500
3501sub reload_sound {
3502 trace "loading sound config from $DATADIR/sound\n";
3503
3504 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3505 or die "$DATADIR/sound $!";
3506
3507 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3508
3509 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3510 my $sound = $soundconf->{compat}[$_]
3511 or next;
3512
3513 my $face = cf::face::find "sound/$sound->[1]";
3514 cf::sound::set $sound->[0] => $face;
3515 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3516 }
3517
3518 while (my ($k, $v) = each %{$soundconf->{event}}) {
3519 my $face = cf::face::find "sound/$v";
3520 cf::sound::set $k => $face;
3521 }
3522}
3523
3356sub reload_resources { 3524sub reload_resources {
3357 warn "reloading resource files...\n"; 3525 trace "reloading resource files...\n";
3358 3526
3359 reload_facedata; 3527 reload_facedata;
3528 reload_sound;
3360 reload_archetypes; 3529 reload_archetypes;
3361 reload_regions; 3530 reload_regions;
3362 reload_treasures; 3531 reload_treasures;
3363 3532
3364 warn "finished reloading resource files\n"; 3533 trace "finished reloading resource files\n";
3365} 3534}
3366 3535
3367sub reload_config { 3536sub reload_config {
3537 trace "reloading config file...\n";
3538
3368 open my $fh, "<:utf8", "$CONFDIR/config" 3539 open my $fh, "<:utf8", "$CONFDIR/config"
3369 or return; 3540 or return;
3370 3541
3371 local $/; 3542 local $/;
3372 *CFG = YAML::Load <$fh>; 3543 *CFG = YAML::XS::Load scalar <$fh>;
3373 3544
3374 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3545 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3375 3546
3376 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3547 $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}; 3548 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3378 3549
3379 if (exists $CFG{mlockall}) { 3550 if (exists $CFG{mlockall}) {
… …
3381 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3552 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3382 and die "WARNING: m(un)lockall failed: $!\n"; 3553 and die "WARNING: m(un)lockall failed: $!\n";
3383 }; 3554 };
3384 warn $@ if $@; 3555 warn $@ if $@;
3385 } 3556 }
3557
3558 trace "finished reloading resource files\n";
3386} 3559}
3387 3560
3388sub pidfile() { 3561sub pidfile() {
3389 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3562 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3390 or die "$PIDFILE: $!"; 3563 or die "$PIDFILE: $!";
… …
3403 seek $fh, 0, 0; 3576 seek $fh, 0, 0;
3404 print $fh $$; 3577 print $fh $$;
3405} 3578}
3406 3579
3407sub main_loop { 3580sub main_loop {
3408 warn "EV::loop starting\n"; 3581 trace "EV::loop starting\n";
3409 if (1) { 3582 if (1) {
3410 EV::loop; 3583 EV::loop;
3411 } 3584 }
3412 warn "EV::loop returned\n"; 3585 trace "EV::loop returned\n";
3413 goto &main_loop unless $REALLY_UNLOOP; 3586 goto &main_loop unless $REALLY_UNLOOP;
3414} 3587}
3415 3588
3416sub main { 3589sub main {
3417 cf::init_globals; # initialise logging 3590 cf::init_globals; # initialise logging
3418 3591
3419 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3592 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3420 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3593 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3421 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3594 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3422 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3595 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 3596
3429 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3597 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3430 3598
3431 # we must not ever block the main coroutine 3599 # we must not ever block the main coroutine
3432 local $Coro::idle = sub { 3600 local $Coro::idle = sub {
… …
3438 }; 3606 };
3439 3607
3440 evthread_start IO::AIO::poll_fileno; 3608 evthread_start IO::AIO::poll_fileno;
3441 3609
3442 cf::sync_job { 3610 cf::sync_job {
3611 cf::init_experience;
3612 cf::init_anim;
3613 cf::init_attackmess;
3614 cf::init_dynamic;
3615
3616 cf::load_settings;
3617 cf::load_materials;
3618
3443 reload_resources; 3619 reload_resources;
3444 reload_config; 3620 reload_config;
3445 db_init; 3621 db_init;
3446 3622
3447 cf::load_settings;
3448 cf::load_materials;
3449 cf::init_uuid; 3623 cf::init_uuid;
3450 cf::init_signals; 3624 cf::init_signals;
3451 cf::init_commands;
3452 cf::init_skills; 3625 cf::init_skills;
3453 3626
3454 cf::init_beforeplay; 3627 cf::init_beforeplay;
3455 3628
3456 atomic; 3629 atomic;
… …
3463 use POSIX (); 3636 use POSIX ();
3464 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3637 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3465 3638
3466 (pop @POST_INIT)->(0) while @POST_INIT; 3639 (pop @POST_INIT)->(0) while @POST_INIT;
3467 }; 3640 };
3641
3642 cf::object::thawer::errors_are_fatal 0;
3643 info "parse errors in files are no longer fatal from this point on.\n";
3468 3644
3469 main_loop; 3645 main_loop;
3470} 3646}
3471 3647
3472############################################################################# 3648#############################################################################
… …
3474 3650
3475# install some emergency cleanup handlers 3651# install some emergency cleanup handlers
3476BEGIN { 3652BEGIN {
3477 our %SIGWATCHER = (); 3653 our %SIGWATCHER = ();
3478 for my $signal (qw(INT HUP TERM)) { 3654 for my $signal (qw(INT HUP TERM)) {
3479 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3655 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3480 cf::cleanup "SIG$signal"; 3656 cf::cleanup "SIG$signal";
3481 }; 3657 };
3482 } 3658 }
3483} 3659}
3484 3660
3485sub write_runtime_sync { 3661sub write_runtime_sync {
3662 my $t0 = AE::time;
3663
3486 # first touch the runtime file to show we are still running: 3664 # first touch the runtime file to show we are still running:
3487 # the fsync below can take a very very long time. 3665 # the fsync below can take a very very long time.
3488 3666
3489 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3667 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3490 3668
3491 my $guard = cf::lock_acquire "write_runtime"; 3669 my $guard = cf::lock_acquire "write_runtime";
3492 3670
3493 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3671 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3494 or return; 3672 or return;
3495 3673
3496 my $value = $cf::RUNTIME + 90 + 10; 3674 my $value = $cf::RUNTIME + 90 + 10;
3497 # 10 is the runtime save interval, for a monotonic clock 3675 # 10 is the runtime save interval, for a monotonic clock
3498 # 60 allows for the watchdog to kill the server. 3676 # 60 allows for the watchdog to kill the server.
… …
3511 or return; 3689 or return;
3512 3690
3513 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3691 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3514 and return; 3692 and return;
3515 3693
3516 warn "runtime file written.\n"; 3694 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3517 3695
3518 1 3696 1
3519} 3697}
3520 3698
3521our $uuid_lock; 3699our $uuid_lock;
… …
3533 or return; 3711 or return;
3534 3712
3535 my $value = uuid_seq uuid_cur; 3713 my $value = uuid_seq uuid_cur;
3536 3714
3537 unless ($value) { 3715 unless ($value) {
3538 warn "cowardly refusing to write zero uuid value!\n"; 3716 info "cowardly refusing to write zero uuid value!\n";
3539 return; 3717 return;
3540 } 3718 }
3541 3719
3542 my $value = uuid_str $value + $uuid_skip; 3720 my $value = uuid_str $value + $uuid_skip;
3543 $uuid_skip = 0; 3721 $uuid_skip = 0;
… …
3553 or return; 3731 or return;
3554 3732
3555 aio_rename "$uuid~", $uuid 3733 aio_rename "$uuid~", $uuid
3556 and return; 3734 and return;
3557 3735
3558 warn "uuid file written ($value).\n"; 3736 trace "uuid file written ($value).\n";
3559 3737
3560 1 3738 1
3561 3739
3562} 3740}
3563 3741
… …
3569} 3747}
3570 3748
3571sub emergency_save() { 3749sub emergency_save() {
3572 my $freeze_guard = cf::freeze_mainloop; 3750 my $freeze_guard = cf::freeze_mainloop;
3573 3751
3574 warn "emergency_perl_save: enter\n"; 3752 info "emergency_perl_save: enter\n";
3753
3754 # this is a trade-off: we want to be very quick here, so
3755 # save all maps without fsync, and later call a global sync
3756 # (which in turn might be very very slow)
3757 local $USE_FSYNC = 0;
3575 3758
3576 cf::sync_job { 3759 cf::sync_job {
3577 # this is a trade-off: we want to be very quick here, so 3760 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 3761
3582 # use a peculiar iteration method to avoid tripping on perl 3762 # use a peculiar iteration method to avoid tripping on perl
3583 # refcount bugs in for. also avoids problems with players 3763 # refcount bugs in for. also avoids problems with players
3584 # and maps saved/destroyed asynchronously. 3764 # and maps saved/destroyed asynchronously.
3585 warn "emergency_perl_save: begin player save\n"; 3765 info "emergency_perl_save: begin player save\n";
3586 for my $login (keys %cf::PLAYER) { 3766 for my $login (keys %cf::PLAYER) {
3587 my $pl = $cf::PLAYER{$login} or next; 3767 my $pl = $cf::PLAYER{$login} or next;
3588 $pl->valid or next; 3768 $pl->valid or next;
3589 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3769 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3590 $pl->save; 3770 $pl->save;
3591 } 3771 }
3592 warn "emergency_perl_save: end player save\n"; 3772 info "emergency_perl_save: end player save\n";
3593 3773
3774 cf::write_runtime_sync; # external watchdog should not bark
3775
3594 warn "emergency_perl_save: begin map save\n"; 3776 info "emergency_perl_save: begin map save\n";
3595 for my $path (keys %cf::MAP) { 3777 for my $path (keys %cf::MAP) {
3596 my $map = $cf::MAP{$path} or next; 3778 my $map = $cf::MAP{$path} or next;
3597 $map->valid or next; 3779 $map->valid or next;
3598 $map->save; 3780 $map->save;
3599 } 3781 }
3600 warn "emergency_perl_save: end map save\n"; 3782 info "emergency_perl_save: end map save\n";
3601 3783
3784 cf::write_runtime_sync; # external watchdog should not bark
3785
3602 warn "emergency_perl_save: begin database checkpoint\n"; 3786 info "emergency_perl_save: begin database checkpoint\n";
3603 BDB::db_env_txn_checkpoint $DB_ENV; 3787 BDB::db_env_txn_checkpoint $DB_ENV;
3604 warn "emergency_perl_save: end database checkpoint\n"; 3788 info "emergency_perl_save: end database checkpoint\n";
3605 3789
3606 warn "emergency_perl_save: begin write uuid\n"; 3790 info "emergency_perl_save: begin write uuid\n";
3607 write_uuid_sync 1; 3791 write_uuid_sync 1;
3608 warn "emergency_perl_save: end write uuid\n"; 3792 info "emergency_perl_save: end write uuid\n";
3793
3794 cf::write_runtime_sync; # external watchdog should not bark
3795
3796 trace "emergency_perl_save: syncing database to disk";
3797 BDB::db_env_txn_checkpoint $DB_ENV;
3798
3799 info "emergency_perl_save: starting sync\n";
3800 IO::AIO::aio_sync sub {
3801 info "emergency_perl_save: finished sync\n";
3802 };
3803
3804 cf::write_runtime_sync; # external watchdog should not bark
3805
3806 trace "emergency_perl_save: flushing outstanding aio requests";
3807 while (IO::AIO::nreqs || BDB::nreqs) {
3808 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3809 }
3810
3811 cf::write_runtime_sync; # external watchdog should not bark
3609 }; 3812 };
3610 3813
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"; 3814 info "emergency_perl_save: leave\n";
3617} 3815}
3618 3816
3619sub post_cleanup { 3817sub post_cleanup {
3620 my ($make_core) = @_; 3818 my ($make_core) = @_;
3621 3819
3820 IO::AIO::flush;
3821
3622 warn Carp::longmess "post_cleanup backtrace" 3822 error Carp::longmess "post_cleanup backtrace"
3623 if $make_core; 3823 if $make_core;
3624 3824
3625 my $fh = pidfile; 3825 my $fh = pidfile;
3626 unlink $PIDFILE if <$fh> == $$; 3826 unlink $PIDFILE if <$fh> == $$;
3627} 3827}
… …
3647 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3847 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3648 for my $name (keys %$leaf_symtab) { 3848 for my $name (keys %$leaf_symtab) {
3649 _gv_clear *{"$pkg$name"}; 3849 _gv_clear *{"$pkg$name"};
3650# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3850# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3651 } 3851 }
3652 warn "cleared package $pkg\n";#d#
3653} 3852}
3654 3853
3655sub do_reload_perl() { 3854sub do_reload_perl() {
3656 # can/must only be called in main 3855 # can/must only be called in main
3657 if ($Coro::current != $Coro::main) { 3856 if (in_main) {
3658 warn "can only reload from main coroutine"; 3857 error "can only reload from main coroutine";
3659 return; 3858 return;
3660 } 3859 }
3661 3860
3662 return if $RELOAD++; 3861 return if $RELOAD++;
3663 3862
3664 my $t1 = EV::time; 3863 my $t1 = AE::time;
3665 3864
3666 while ($RELOAD) { 3865 while ($RELOAD) {
3667 warn "reloading..."; 3866 info "reloading...";
3668 3867
3669 warn "entering sync_job"; 3868 trace "entering sync_job";
3670 3869
3671 cf::sync_job { 3870 cf::sync_job {
3672 cf::write_runtime_sync; # external watchdog should not bark
3673 cf::emergency_save; 3871 cf::emergency_save;
3674 cf::write_runtime_sync; # external watchdog should not bark
3675 3872
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"; 3873 trace "cancelling all extension coros";
3687 $_->cancel for values %EXT_CORO; 3874 $_->cancel for values %EXT_CORO;
3688 %EXT_CORO = (); 3875 %EXT_CORO = ();
3689 3876
3690 warn "removing commands"; 3877 trace "removing commands";
3691 %COMMAND = (); 3878 %COMMAND = ();
3692 3879
3693 warn "removing ext/exti commands"; 3880 trace "removing ext/exti commands";
3694 %EXTCMD = (); 3881 %EXTCMD = ();
3695 %EXTICMD = (); 3882 %EXTICMD = ();
3696 3883
3697 warn "unloading/nuking all extensions"; 3884 trace "unloading/nuking all extensions";
3698 for my $pkg (@EXTS) { 3885 for my $pkg (@EXTS) {
3699 warn "... unloading $pkg"; 3886 trace "... unloading $pkg";
3700 3887
3701 if (my $cb = $pkg->can ("unload")) { 3888 if (my $cb = $pkg->can ("unload")) {
3702 eval { 3889 eval {
3703 $cb->($pkg); 3890 $cb->($pkg);
3704 1 3891 1
3705 } or warn "$pkg unloaded, but with errors: $@"; 3892 } or error "$pkg unloaded, but with errors: $@";
3706 } 3893 }
3707 3894
3708 warn "... clearing $pkg"; 3895 trace "... clearing $pkg";
3709 clear_package $pkg; 3896 clear_package $pkg;
3710 } 3897 }
3711 3898
3712 warn "unloading all perl modules loaded from $LIBDIR"; 3899 trace "unloading all perl modules loaded from $LIBDIR";
3713 while (my ($k, $v) = each %INC) { 3900 while (my ($k, $v) = each %INC) {
3714 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3901 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3715 3902
3716 warn "... unloading $k"; 3903 trace "... unloading $k";
3717 delete $INC{$k}; 3904 delete $INC{$k};
3718 3905
3719 $k =~ s/\.pm$//; 3906 $k =~ s/\.pm$//;
3720 $k =~ s/\//::/g; 3907 $k =~ s/\//::/g;
3721 3908
… …
3724 } 3911 }
3725 3912
3726 clear_package $k; 3913 clear_package $k;
3727 } 3914 }
3728 3915
3729 warn "getting rid of safe::, as good as possible"; 3916 trace "getting rid of safe::, as good as possible";
3730 clear_package "safe::$_" 3917 clear_package "safe::$_"
3731 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3918 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3732 3919
3733 warn "unloading cf.pm \"a bit\""; 3920 trace "unloading cf.pm \"a bit\"";
3734 delete $INC{"cf.pm"}; 3921 delete $INC{"cf.pm"};
3735 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 3922 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3736 3923
3737 # don't, removes xs symbols, too, 3924 # don't, removes xs symbols, too,
3738 # and global variables created in xs 3925 # and global variables created in xs
3739 #clear_package __PACKAGE__; 3926 #clear_package __PACKAGE__;
3740 3927
3741 warn "unload completed, starting to reload now"; 3928 info "unload completed, starting to reload now";
3742 3929
3743 warn "reloading cf.pm"; 3930 trace "reloading cf.pm";
3744 require cf; 3931 require cf;
3745 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3932 cf::_connect_to_perl_1;
3746 3933
3747 warn "loading config and database again"; 3934 trace "loading config and database again";
3748 cf::reload_config; 3935 cf::reload_config;
3749 3936
3750 warn "loading extensions"; 3937 trace "loading extensions";
3751 cf::load_extensions; 3938 cf::load_extensions;
3752 3939
3753 if ($REATTACH_ON_RELOAD) { 3940 if ($REATTACH_ON_RELOAD) {
3754 warn "reattaching attachments to objects/players"; 3941 trace "reattaching attachments to objects/players";
3755 _global_reattach; # objects, sockets 3942 _global_reattach; # objects, sockets
3756 warn "reattaching attachments to maps"; 3943 trace "reattaching attachments to maps";
3757 reattach $_ for values %MAP; 3944 reattach $_ for values %MAP;
3758 warn "reattaching attachments to players"; 3945 trace "reattaching attachments to players";
3759 reattach $_ for values %PLAYER; 3946 reattach $_ for values %PLAYER;
3760 } 3947 }
3761 3948
3762 warn "running post_init jobs"; 3949 trace "running post_init jobs";
3763 (pop @POST_INIT)->(1) while @POST_INIT; 3950 (pop @POST_INIT)->(1) while @POST_INIT;
3764 3951
3765 warn "leaving sync_job"; 3952 trace "leaving sync_job";
3766 3953
3767 1 3954 1
3768 } or do { 3955 } or do {
3769 warn $@; 3956 error $@;
3770 cf::cleanup "error while reloading, exiting."; 3957 cf::cleanup "error while reloading, exiting.";
3771 }; 3958 };
3772 3959
3773 warn "reloaded"; 3960 info "reloaded";
3774 --$RELOAD; 3961 --$RELOAD;
3775 } 3962 }
3776 3963
3777 $t1 = EV::time - $t1; 3964 $t1 = AE::time - $t1;
3778 warn "reload completed in ${t1}s\n"; 3965 info "reload completed in ${t1}s\n";
3779}; 3966};
3780 3967
3781our $RELOAD_WATCHER; # used only during reload 3968our $RELOAD_WATCHER; # used only during reload
3782 3969
3783sub reload_perl() { 3970sub reload_perl() {
… …
3785 # coro crashes during coro_state_free->destroy here. 3972 # coro crashes during coro_state_free->destroy here.
3786 3973
3787 $RELOAD_WATCHER ||= cf::async { 3974 $RELOAD_WATCHER ||= cf::async {
3788 Coro::AIO::aio_wait cache_extensions; 3975 Coro::AIO::aio_wait cache_extensions;
3789 3976
3790 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 3977 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3791 do_reload_perl; 3978 do_reload_perl;
3792 undef $RELOAD_WATCHER; 3979 undef $RELOAD_WATCHER;
3793 }; 3980 };
3794 }; 3981 };
3795} 3982}
… …
3812 3999
3813our @WAIT_FOR_TICK; 4000our @WAIT_FOR_TICK;
3814our @WAIT_FOR_TICK_BEGIN; 4001our @WAIT_FOR_TICK_BEGIN;
3815 4002
3816sub wait_for_tick { 4003sub wait_for_tick {
3817 return if tick_inhibit || $Coro::current == $Coro::main; 4004 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3818 4005
3819 my $signal = new Coro::Signal; 4006 my $signal = new Coro::Signal;
3820 push @WAIT_FOR_TICK, $signal; 4007 push @WAIT_FOR_TICK, $signal;
3821 $signal->wait; 4008 $signal->wait;
3822} 4009}
3823 4010
3824sub wait_for_tick_begin { 4011sub wait_for_tick_begin {
3825 return if tick_inhibit || $Coro::current == $Coro::main; 4012 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3826 4013
3827 my $signal = new Coro::Signal; 4014 my $signal = new Coro::Signal;
3828 push @WAIT_FOR_TICK_BEGIN, $signal; 4015 push @WAIT_FOR_TICK_BEGIN, $signal;
3829 $signal->wait; 4016 $signal->wait;
3830} 4017}
… …
3836 return; 4023 return;
3837 } 4024 }
3838 4025
3839 cf::server_tick; # one server iteration 4026 cf::server_tick; # one server iteration
3840 4027
4028 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4029
3841 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4030 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3842 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4031 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3843 Coro::async_pool { 4032 Coro::async_pool {
3844 $Coro::current->{desc} = "runtime saver"; 4033 $Coro::current->{desc} = "runtime saver";
3845 write_runtime_sync 4034 write_runtime_sync
3846 or warn "ERROR: unable to write runtime file: $!"; 4035 or error "ERROR: unable to write runtime file: $!";
3847 }; 4036 };
3848 } 4037 }
3849 4038
3850 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4039 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3851 $sig->send; 4040 $sig->send;
… …
3859 4048
3860 if (0) { 4049 if (0) {
3861 if ($NEXT_TICK) { 4050 if ($NEXT_TICK) {
3862 my $jitter = $TICK_START - $NEXT_TICK; 4051 my $jitter = $TICK_START - $NEXT_TICK;
3863 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4052 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3864 warn "jitter $JITTER\n";#d# 4053 debug "jitter $JITTER\n";#d#
3865 } 4054 }
3866 } 4055 }
3867} 4056}
3868 4057
3869{ 4058{
3870 # configure BDB 4059 # configure BDB
3871 4060
3872 BDB::min_parallel 8; 4061 BDB::min_parallel 16;
3873 BDB::max_poll_reqs $TICK * 0.1; 4062 BDB::max_poll_reqs $TICK * 0.1;
3874 $AnyEvent::BDB::WATCHER->priority (1); 4063 $AnyEvent::BDB::WATCHER->priority (1);
3875 4064
3876 unless ($DB_ENV) { 4065 unless ($DB_ENV) {
3877 $DB_ENV = BDB::db_env_create; 4066 $DB_ENV = BDB::db_env_create;
… …
3958 } 4147 }
3959} 4148}
3960 4149
3961# load additional modules 4150# load additional modules
3962require "cf/$_.pm" for @EXTRA_MODULES; 4151require "cf/$_.pm" for @EXTRA_MODULES;
4152cf::_connect_to_perl_2;
3963 4153
3964END { cf::emergency_save } 4154END { cf::emergency_save }
3965 4155
39661 41561
3967 4157

Diff Legend

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