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.475 by root, Tue Jul 21 06:17:00 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
226 254
227BEGIN { 255sub error(@) { LOG llevError, join "", @_ }
228 *CORE::GLOBAL::warn = sub { 256sub warn (@) { LOG llevWarn , join "", @_ }
257sub info (@) { LOG llevInfo , join "", @_ }
258sub debug(@) { LOG llevDebug, join "", @_ }
259sub trace(@) { LOG llevTrace, join "", @_ }
260
261$Coro::State::WARNHOOK = sub {
229 my $msg = join "", @_; 262 my $msg = join "", @_;
230 263
231 $msg .= "\n" 264 $msg .= "\n"
232 unless $msg =~ /\n$/; 265 unless $msg =~ /\n$/;
233 266
234 $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;
235 268
236 LOG llevError, $msg; 269 LOG llevWarn, $msg;
237 }; 270};
238}
239 271
240$Coro::State::DIEHOOK = sub { 272$Coro::State::DIEHOOK = sub {
241 return unless $^S eq 0; # "eq", not "==" 273 return unless $^S eq 0; # "eq", not "=="
242 274
243 if ($Coro::current == $Coro::main) {#d# 275 error Carp::longmess $_[0];
276
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 warn Carp::longmess $_[0];
250 Coro::terminate 283 Coro::terminate
251}; 284};
252
253$SIG{__DIE__} = sub { }; #d#?
254 285
255@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 286@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
256@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 287@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
257@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 288@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
258@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 289@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
272)) { 303)) {
273 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 304 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
274} 305}
275 306
276$EV::DIED = sub { 307$EV::DIED = sub {
277 warn "error in event callback: @_"; 308 Carp::cluck "error in event callback: @_";
278}; 309};
279 310
280############################################################################# 311#############################################################################
281 312
282=head2 UTILITY FUNCTIONS 313=head2 UTILITY FUNCTIONS
… …
379} 410}
380 411
381=item cf::periodic $interval, $cb 412=item cf::periodic $interval, $cb
382 413
383Like 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
384get spread over timer. 415get spread over time.
385 416
386=cut 417=cut
387 418
388sub periodic($$) { 419sub periodic($$) {
389 my ($interval, $cb) = @_; 420 my ($interval, $cb) = @_;
… …
406 437
407=cut 438=cut
408 439
409our @SLOT_QUEUE; 440our @SLOT_QUEUE;
410our $SLOT_QUEUE; 441our $SLOT_QUEUE;
442our $SLOT_DECAY = 0.9;
411 443
412$SLOT_QUEUE->cancel if $SLOT_QUEUE; 444$SLOT_QUEUE->cancel if $SLOT_QUEUE;
413$SLOT_QUEUE = Coro::async { 445$SLOT_QUEUE = Coro::async {
414 $Coro::current->desc ("timeslot manager"); 446 $Coro::current->desc ("timeslot manager");
415 447
416 my $signal = new Coro::Signal; 448 my $signal = new Coro::Signal;
449 my $busy;
417 450
418 while () { 451 while () {
419 next_job: 452 next_job:
453
420 my $avail = cf::till_tick; 454 my $avail = cf::till_tick;
421 if ($avail > 0.01) { 455
422 for (0 .. $#SLOT_QUEUE) { 456 for (0 .. $#SLOT_QUEUE) {
423 if ($SLOT_QUEUE[$_][0] < $avail) { 457 if ($SLOT_QUEUE[$_][0] <= $avail) {
458 $busy = 0;
424 my $job = splice @SLOT_QUEUE, $_, 1, (); 459 my $job = splice @SLOT_QUEUE, $_, 1, ();
425 $job->[2]->send; 460 $job->[2]->send;
426 Coro::cede; 461 Coro::cede;
427 goto next_job; 462 goto next_job;
428 } 463 } else {
464 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
429 } 465 }
430 } 466 }
431 467
432 if (@SLOT_QUEUE) { 468 if (@SLOT_QUEUE) {
433 # 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
434 push @cf::WAIT_FOR_TICK, $signal; 470 push @cf::WAIT_FOR_TICK, $signal;
435 $signal->wait; 471 $signal->wait;
436 } else { 472 } else {
473 $busy = 0;
437 Coro::schedule; 474 Coro::schedule;
438 } 475 }
439 } 476 }
440}; 477};
441 478
442sub get_slot($;$$) { 479sub get_slot($;$$) {
443 return if tick_inhibit || $Coro::current == $Coro::main; 480 return if tick_inhibit || $Coro::current == $Coro::main;
444 481
445 my ($time, $pri, $name) = @_; 482 my ($time, $pri, $name) = @_;
446 483
447 $time = $TICK * .6 if $time > $TICK * .6; 484 $time = clamp $time, 0.01, $TICK * .6;
485
448 my $sig = new Coro::Signal; 486 my $sig = new Coro::Signal;
449 487
450 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 488 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
451 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 489 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
452 $SLOT_QUEUE->ready; 490 $SLOT_QUEUE->ready;
… …
478=cut 516=cut
479 517
480sub sync_job(&) { 518sub sync_job(&) {
481 my ($job) = @_; 519 my ($job) = @_;
482 520
483 if ($Coro::current == $Coro::main) { 521 if (in_main) {
484 my $time = EV::time; 522 my $time = AE::time;
485 523
486 # this is the main coro, too bad, we have to block 524 # this is the main coro, too bad, we have to block
487 # till the operation succeeds, freezing the server :/ 525 # till the operation succeeds, freezing the server :/
488 526
489 LOG llevError, Carp::longmess "sync job";#d# 527 #LOG llevError, Carp::longmess "sync job";#d#
490 528
491 my $freeze_guard = freeze_mainloop; 529 my $freeze_guard = freeze_mainloop;
492 530
493 my $busy = 1; 531 my $busy = 1;
494 my @res; 532 my @res;
495 533
496 (async { 534 (async {
497 $Coro::current->desc ("sync job coro"); 535 $Coro::current->desc ("sync job coro");
498 @res = eval { $job->() }; 536 @res = eval { $job->() };
499 warn $@ if $@; 537 error $@ if $@;
500 undef $busy; 538 undef $busy;
501 })->prio (Coro::PRIO_MAX); 539 })->prio (Coro::PRIO_MAX);
502 540
503 while ($busy) { 541 while ($busy) {
504 if (Coro::nready) { 542 if (Coro::nready) {
… …
506 } else { 544 } else {
507 EV::loop EV::LOOP_ONESHOT; 545 EV::loop EV::LOOP_ONESHOT;
508 } 546 }
509 } 547 }
510 548
511 my $time = EV::time - $time; 549 my $time = AE::time - $time;
512 550
513 $TICK_START += $time; # do not account sync jobs to server load 551 $TICK_START += $time; # do not account sync jobs to server load
514 552
515 wantarray ? @res : $res[0] 553 wantarray ? @res : $res[0]
516 } else { 554 } else {
… …
560 reset_signals; 598 reset_signals;
561 &$cb 599 &$cb
562 }, @args; 600 }, @args;
563 601
564 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 )
565} 614}
566 615
567=item $coin = coin_from_name $name 616=item $coin = coin_from_name $name
568 617
569=cut 618=cut
… …
606within each server. 655within each server.
607 656
608=cut 657=cut
609 658
610sub db_table($) { 659sub db_table($) {
660 cf::error "db_get called from main context"
661 if $Coro::current == $Coro::main;
662
611 my ($name) = @_; 663 my ($name) = @_;
612 my $db = BDB::db_create $DB_ENV; 664 my $db = BDB::db_create $DB_ENV;
613 665
614 eval { 666 eval {
615 $db->set_flags (BDB::CHKSUM); 667 $db->set_flags (BDB::CHKSUM);
… …
625} 677}
626 678
627our $DB; 679our $DB;
628 680
629sub db_init { 681sub db_init {
630 cf::sync_job {
631 $DB ||= db_table "db"; 682 $DB ||= db_table "db";
632 };
633} 683}
634 684
635sub db_get($$) { 685sub db_get($$) {
636 my $key = "$_[0]/$_[1]"; 686 my $key = "$_[0]/$_[1]";
637 687
638 cf::sync_job { 688 cf::error "db_get called from main context"
689 if $Coro::current == $Coro::main;
690
639 BDB::db_get $DB, undef, $key, my $data; 691 BDB::db_get $DB, undef, $key, my $data;
640 692
641 $! ? () 693 $! ? ()
642 : $data 694 : $data
643 }
644} 695}
645 696
646sub db_put($$$) { 697sub db_put($$$) {
647 BDB::dbreq_pri 4; 698 BDB::dbreq_pri 4;
648 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 699 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
704 755
705 my $t1 = Time::HiRes::time; 756 my $t1 = Time::HiRes::time;
706 my $data = $process->(\@data); 757 my $data = $process->(\@data);
707 my $t2 = Time::HiRes::time; 758 my $t2 = Time::HiRes::time;
708 759
709 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 760 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
710 761
711 db_put cache => "$id/data", $data; 762 db_put cache => "$id/data", $data;
712 db_put cache => "$id/md5" , $md5; 763 db_put cache => "$id/md5" , $md5;
713 db_put cache => "$id/meta", $meta; 764 db_put cache => "$id/meta", $meta;
714 765
… …
724 775
725=cut 776=cut
726 777
727sub datalog($@) { 778sub datalog($@) {
728 my ($type, %kv) = @_; 779 my ($type, %kv) = @_;
729 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 780 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
730} 781}
731 782
732=back 783=back
733 784
734=cut 785=cut
… …
929 980
930 } elsif (exists $cb_id{$type}) { 981 } elsif (exists $cb_id{$type}) {
931 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 982 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
932 983
933 } elsif (ref $type) { 984 } elsif (ref $type) {
934 warn "attaching objects not supported, ignoring.\n"; 985 error "attaching objects not supported, ignoring.\n";
935 986
936 } else { 987 } else {
937 shift @arg; 988 shift @arg;
938 warn "attach argument '$type' not supported, ignoring.\n"; 989 error "attach argument '$type' not supported, ignoring.\n";
939 } 990 }
940 } 991 }
941} 992}
942 993
943sub _object_attach { 994sub _object_attach {
… …
953 _attach $registry, $klass, @attach; 1004 _attach $registry, $klass, @attach;
954 } 1005 }
955 1006
956 $obj->{$name} = \%arg; 1007 $obj->{$name} = \%arg;
957 } else { 1008 } else {
958 warn "object uses attachment '$name' which is not available, postponing.\n"; 1009 info "object uses attachment '$name' which is not available, postponing.\n";
959 } 1010 }
960 1011
961 $obj->{_attachment}{$name} = undef; 1012 $obj->{_attachment}{$name} = undef;
962} 1013}
963 1014
… …
1022 1073
1023 for (@$callbacks) { 1074 for (@$callbacks) {
1024 eval { &{$_->[1]} }; 1075 eval { &{$_->[1]} };
1025 1076
1026 if ($@) { 1077 if ($@) {
1027 warn "$@";
1028 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1078 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1029 override; 1079 override;
1030 } 1080 }
1031 1081
1032 return 1 if $override; 1082 return 1 if $override;
1033 } 1083 }
… …
1112 for (@$attach) { 1162 for (@$attach) {
1113 my ($klass, @attach) = @$_; 1163 my ($klass, @attach) = @$_;
1114 _attach $registry, $klass, @attach; 1164 _attach $registry, $klass, @attach;
1115 } 1165 }
1116 } else { 1166 } else {
1117 warn "object uses attachment '$name' that is not available, postponing.\n"; 1167 info "object uses attachment '$name' that is not available, postponing.\n";
1118 } 1168 }
1119 } 1169 }
1120} 1170}
1121 1171
1122cf::attachable->attach ( 1172cf::attachable->attach (
… …
1149 my ($filename, $rdata, $objs) = @_; 1199 my ($filename, $rdata, $objs) = @_;
1150 1200
1151 sync_job { 1201 sync_job {
1152 if (length $$rdata) { 1202 if (length $$rdata) {
1153 utf8::decode (my $decname = $filename); 1203 utf8::decode (my $decname = $filename);
1154 warn sprintf "saving %s (%d,%d)\n", 1204 trace sprintf "saving %s (%d,%d)\n",
1155 $decname, length $$rdata, scalar @$objs; 1205 $decname, length $$rdata, scalar @$objs
1206 if $VERBOSE_IO;
1156 1207
1157 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1208 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1158 aio_chmod $fh, SAVE_MODE; 1209 aio_chmod $fh, SAVE_MODE;
1159 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1210 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1160 if ($cf::USE_FSYNC) { 1211 if ($cf::USE_FSYNC) {
… …
1182 aio_rename "$filename~", $filename; 1233 aio_rename "$filename~", $filename;
1183 1234
1184 $filename =~ s%/[^/]+$%%; 1235 $filename =~ s%/[^/]+$%%;
1185 aio_pathsync $filename if $cf::USE_FSYNC; 1236 aio_pathsync $filename if $cf::USE_FSYNC;
1186 } else { 1237 } else {
1187 warn "unable to save objects: $filename~: $!\n"; 1238 error "unable to save objects: $filename~: $!\n";
1188 } 1239 }
1189 } else { 1240 } else {
1190 aio_unlink $filename; 1241 aio_unlink $filename;
1191 aio_unlink "$filename.pst"; 1242 aio_unlink "$filename.pst";
1192 } 1243 }
… …
1216 my $st = eval { Coro::Storable::thaw $av }; 1267 my $st = eval { Coro::Storable::thaw $av };
1217 $av = $st->{objs}; 1268 $av = $st->{objs};
1218 } 1269 }
1219 1270
1220 utf8::decode (my $decname = $filename); 1271 utf8::decode (my $decname = $filename);
1221 warn sprintf "loading %s (%d,%d)\n", 1272 trace sprintf "loading %s (%d,%d)\n",
1222 $decname, length $data, scalar @{$av || []}; 1273 $decname, length $data, scalar @{$av || []}
1274 if $VERBOSE_IO;
1223 1275
1224 ($data, $av) 1276 ($data, $av)
1225} 1277}
1226 1278
1227=head2 COMMAND CALLBACKS 1279=head2 COMMAND CALLBACKS
… …
1286} 1338}
1287 1339
1288use File::Glob (); 1340use File::Glob ();
1289 1341
1290cf::player->attach ( 1342cf::player->attach (
1291 on_command => sub { 1343 on_unknown_command => sub {
1292 my ($pl, $name, $params) = @_; 1344 my ($pl, $name, $params) = @_;
1293 1345
1294 my $cb = $COMMAND{$name} 1346 my $cb = $COMMAND{$name}
1295 or return; 1347 or return;
1296 1348
… …
1319 1371
1320 $pl->ext_reply ($reply, @reply) 1372 $pl->ext_reply ($reply, @reply)
1321 if $reply; 1373 if $reply;
1322 1374
1323 } else { 1375 } else {
1324 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1376 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1325 } 1377 }
1326 1378
1327 cf::override; 1379 cf::override;
1328 }, 1380 },
1329); 1381);
… …
1340 1392
1341 $grp 1393 $grp
1342} 1394}
1343 1395
1344sub load_extensions { 1396sub load_extensions {
1397 info "loading extensions...";
1398
1345 cf::sync_job { 1399 cf::sync_job {
1346 my %todo; 1400 my %todo;
1347 1401
1348 for my $path (<$LIBDIR/*.ext>) { 1402 for my $path (<$LIBDIR/*.ext>) {
1349 next unless -r $path; 1403 next unless -r $path;
… …
1367 1421
1368 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1422 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1369 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1423 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1370 1424
1371 $ext{source} = 1425 $ext{source} =
1372 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1426 "package $pkg; use common::sense;\n"
1373 . "#line 1 \"$path\"\n{\n" 1427 . "#line 1 \"$path\"\n{\n"
1374 . $source 1428 . $source
1375 . "\n};\n1"; 1429 . "\n};\n1";
1376 1430
1377 $todo{$base} = \%ext; 1431 $todo{$base} = \%ext;
1378 } 1432 }
1379 1433
1434 my $pass = 0;
1380 my %done; 1435 my %done;
1381 while (%todo) { 1436 while (%todo) {
1382 my $progress; 1437 my $progress;
1383 1438
1439 ++$pass;
1440
1441 ext:
1384 while (my ($k, $v) = each %todo) { 1442 while (my ($k, $v) = each %todo) {
1385 for (split /,\s*/, $v->{meta}{depends}) { 1443 for (split /,\s*/, $v->{meta}{depends}) {
1386 goto skip 1444 next ext
1387 unless exists $done{$_}; 1445 unless exists $done{$_};
1388 } 1446 }
1389 1447
1390 warn "... loading '$k' into '$v->{pkg}'\n"; 1448 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1391 1449
1392 unless (eval $v->{source}) { 1450 my $active = eval $v->{source};
1451
1452 if (length $@) {
1393 my $msg = $@ ? "$v->{path}: $@\n" 1453 error "$v->{path}: $@\n";
1394 : "$v->{base}: extension inactive.\n"; 1454 undef $@; # work around perl 5.10.0 utf-8 caching bug
1395 1455
1396 if (exists $v->{meta}{mandatory}) {
1397 warn $msg;
1398 cf::cleanup "mandatory extension failed to load, exiting."; 1456 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1399 } 1457 if exists $v->{meta}{mandatory};
1400 1458
1401 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;
1402 } 1468 }
1403
1404 $done{$k} = delete $todo{$k};
1405 push @EXTS, $v->{pkg};
1406 $progress = 1;
1407 } 1469 }
1408 1470
1409 skip: 1471 unless ($progress) {
1410 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1472 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1411 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 }
1412 } 1479 }
1413 }; 1480 };
1414} 1481}
1415 1482
1416############################################################################# 1483#############################################################################
… …
1500 $cf::PLAYER{$login} = $pl 1567 $cf::PLAYER{$login} = $pl
1501 } 1568 }
1502 } 1569 }
1503} 1570}
1504 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
1505sub save($) { 1585sub save($) {
1506 my ($pl) = @_; 1586 my ($pl) = @_;
1507 1587
1508 return if $pl->{deny_save}; 1588 return if $pl->{deny_save};
1509 1589
… …
1514 1594
1515 aio_mkdir playerdir $pl, 0770; 1595 aio_mkdir playerdir $pl, 0770;
1516 $pl->{last_save} = $cf::RUNTIME; 1596 $pl->{last_save} = $cf::RUNTIME;
1517 1597
1518 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];
1519 1602
1520 $pl->save_pl ($path); 1603 $pl->save_pl ($path);
1521 cf::cede_to_tick; 1604 cf::cede_to_tick;
1522} 1605}
1523 1606
… …
1560 $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
1561 1644
1562 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1645 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1563 $pl->deactivate; 1646 $pl->deactivate;
1564 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;
1565 $pl->ob->check_score;
1566 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1648 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1567 $pl->ns->destroy if $pl->ns; 1649 $pl->ns->destroy if $pl->ns;
1568 1650
1569 my $path = playerdir $pl; 1651 my $path = playerdir $pl;
1570 my $temp = "$path~$cf::RUNTIME~deleting~"; 1652 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1625 \@logins 1707 \@logins
1626} 1708}
1627 1709
1628=item $player->maps 1710=item $player->maps
1629 1711
1712=item cf::player::maps $login
1713
1630Returns an arrayref of map paths that are private for this 1714Returns an arrayref of map paths that are private for this
1631player. May block. 1715player. May block.
1632 1716
1633=cut 1717=cut
1634 1718
… …
1696=cut 1780=cut
1697 1781
1698sub find_by_path($) { 1782sub find_by_path($) {
1699 my ($path) = @_; 1783 my ($path) = @_;
1700 1784
1785 $path =~ s/^~[^\/]*//; # skip ~login
1786
1701 my ($match, $specificity); 1787 my ($match, $specificity);
1702 1788
1703 for my $region (list) { 1789 for my $region (list) {
1704 if ($region->{match} && $path =~ $region->{match}) { 1790 if ($region->{match} && $path =~ $region->{match}) {
1705 ($match, $specificity) = ($region, $region->specificity) 1791 ($match, $specificity) = ($region, $region->specificity)
… …
1736 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
1737 1823
1738 # mit "rum" bekleckern, nicht 1824 # mit "rum" bekleckern, nicht
1739 $self->_create_random_map ( 1825 $self->_create_random_map (
1740 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1826 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1741 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1827 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1742 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1828 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1743 $rmp->{exit_on_final_map}, 1829 $rmp->{exit_on_final_map},
1744 $rmp->{xsize}, $rmp->{ysize}, 1830 $rmp->{xsize}, $rmp->{ysize},
1745 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1831 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1746 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1832 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1761 1847
1762sub register { 1848sub register {
1763 my (undef, $regex, $prio) = @_; 1849 my (undef, $regex, $prio) = @_;
1764 my $pkg = caller; 1850 my $pkg = caller;
1765 1851
1766 no strict;
1767 push @{"$pkg\::ISA"}, __PACKAGE__; 1852 push @{"$pkg\::ISA"}, __PACKAGE__;
1768 1853
1769 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1854 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1770} 1855}
1771 1856
1772# also paths starting with '/' 1857# also paths starting with '/'
1773$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1858$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1774 1859
1775sub thawer_merge { 1860sub thawer_merge {
1776 my ($self, $merge) = @_; 1861 my ($self, $merge) = @_;
1777 1862
1778 # we have to keep some variables in memory intact 1863 # we have to keep some variables in memory intact
… …
1992 2077
1993 $cf::MAP{$path} = $map 2078 $cf::MAP{$path} = $map
1994 } 2079 }
1995} 2080}
1996 2081
1997sub pre_load { } 2082sub pre_load { }
1998sub post_load { } 2083#sub post_load { } # XS
1999 2084
2000sub load { 2085sub load {
2001 my ($self) = @_; 2086 my ($self) = @_;
2002 2087
2003 local $self->{deny_reset} = 1; # loading can take a long time 2088 local $self->{deny_reset} = 1; # loading can take a long time
… …
2060 } 2145 }
2061 2146
2062 $self->post_load; 2147 $self->post_load;
2063} 2148}
2064 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
2065sub customise_for { 2153sub customise_for {
2066 my ($self, $ob) = @_; 2154 my ($self, $ob) = @_;
2067 2155
2068 return find "~" . $ob->name . "/" . $self->{path} 2156 return find "~" . $ob->name . "/" . $self->{path}
2069 if $self->per_player; 2157 if $self->per_player;
… …
2085 or next; 2173 or next;
2086 $neigh = find $neigh, $map 2174 $neigh = find $neigh, $map
2087 or next; 2175 or next;
2088 $neigh->load; 2176 $neigh->load;
2089 2177
2178 # now find the diagonal neighbours
2090 push @neigh, 2179 push @neigh,
2091 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2180 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2092 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2181 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2093 } 2182 }
2094 2183
… …
2101} 2190}
2102 2191
2103sub find_sync { 2192sub find_sync {
2104 my ($path, $origin) = @_; 2193 my ($path, $origin) = @_;
2105 2194
2106 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
2107} 2199}
2108 2200
2109sub do_load_sync { 2201sub do_load_sync {
2110 my ($map) = @_; 2202 my ($map) = @_;
2111 2203
2112 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2204 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2113 if $Coro::current == $Coro::main; 2205 if $Coro::current == $Coro::main;
2114 2206
2115 cf::sync_job { $map->load }; 2207 $map->load;
2116} 2208}
2117 2209
2118our %MAP_PREFETCH; 2210our %MAP_PREFETCH;
2119our $MAP_PREFETCHER = undef; 2211our $MAP_PREFETCHER = undef;
2120 2212
… …
2146 $MAP_PREFETCHER->prio (6); 2238 $MAP_PREFETCHER->prio (6);
2147 2239
2148 () 2240 ()
2149} 2241}
2150 2242
2243# common code, used by both ->save and ->swapout
2151sub save { 2244sub _save {
2152 my ($self) = @_; 2245 my ($self) = @_;
2153
2154 my $lock = cf::lock_acquire "map_data:$self->{path}";
2155 2246
2156 $self->{last_save} = $cf::RUNTIME; 2247 $self->{last_save} = $cf::RUNTIME;
2157 2248
2158 return unless $self->dirty; 2249 return unless $self->dirty;
2159 2250
… …
2179 } else { 2270 } else {
2180 $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);
2181 } 2272 }
2182} 2273}
2183 2274
2275sub save {
2276 my ($self) = @_;
2277
2278 my $lock = cf::lock_acquire "map_data:$self->{path}";
2279
2280 $self->_save;
2281}
2282
2184sub swap_out { 2283sub swap_out {
2185 my ($self) = @_; 2284 my ($self) = @_;
2186 2285
2187 # save first because save cedes
2188 $self->save;
2189
2190 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2286 my $lock = cf::lock_acquire "map_data:$self->{path}";
2191 2287
2192 return if $self->players;
2193 return if $self->in_memory != cf::MAP_ACTIVE; 2288 return if $self->in_memory != cf::MAP_ACTIVE;
2194 return if $self->{deny_save}; 2289 return if $self->{deny_save};
2290 return if $self->players;
2195 2291
2292 # first deactivate the map and "unlink" it from the core
2293 $self->deactivate;
2294 $_->clear_links_to ($self) for values %cf::MAP;
2196 $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};
2197 2342
2198 $self->deactivate; 2343 $self->deactivate;
2199 $_->clear_links_to ($self) for values %cf::MAP; 2344 $_->clear_links_to ($self) for values %cf::MAP;
2200 $self->clear; 2345 $self->clear;
2201}
2202
2203sub reset_at {
2204 my ($self) = @_;
2205
2206 # TODO: safety, remove and allow resettable per-player maps
2207 return 1e99 if $self->{deny_reset};
2208
2209 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2210 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2211
2212 $time + $to
2213}
2214
2215sub should_reset {
2216 my ($self) = @_;
2217
2218 $self->reset_at <= $cf::RUNTIME
2219}
2220
2221sub reset {
2222 my ($self) = @_;
2223
2224 my $lock = cf::lock_acquire "map_data:$self->{path}";
2225
2226 return if $self->players;
2227
2228 warn "resetting map ", $self->path;
2229
2230 $self->in_memory (cf::MAP_SWAPPED);
2231
2232 # need to save uniques path
2233 unless ($self->{deny_save}) {
2234 my $uniq = $self->uniq_path; utf8::encode $uniq;
2235
2236 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2237 if $uniq;
2238 }
2239
2240 delete $cf::MAP{$self->path};
2241
2242 $self->deactivate;
2243 $_->clear_links_to ($self) for values %cf::MAP;
2244 $self->clear;
2245 2346
2246 $self->unlink_save; 2347 $self->unlink_save;
2247 $self->destroy; 2348 $self->destroy;
2248} 2349}
2249 2350
… …
2257 2358
2258 delete $cf::MAP{$self->path}; 2359 delete $cf::MAP{$self->path};
2259 2360
2260 $self->unlink_save; 2361 $self->unlink_save;
2261 2362
2262 bless $self, "cf::map"; 2363 bless $self, "cf::map::wrap";
2263 delete $self->{deny_reset}; 2364 delete $self->{deny_reset};
2264 $self->{deny_save} = 1; 2365 $self->{deny_save} = 1;
2265 $self->reset_timeout (1); 2366 $self->reset_timeout (1);
2266 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2367 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2267 2368
… …
2324 : normalise $_ 2425 : normalise $_
2325 } @{ aio_readdir $UNIQUEDIR or [] } 2426 } @{ aio_readdir $UNIQUEDIR or [] }
2326 ] 2427 ]
2327} 2428}
2328 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
2329=back 2462=back
2330 2463
2331=head3 cf::object 2464=head3 cf::object
2332 2465
2333=cut 2466=cut
… …
2465 2598
2466Freezes 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}>).
2467 2600
2468The 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.
2469for 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,
2470though, 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
2471map. 2604map.
2472 2605
2473Will never block. 2606Will never block.
2474 2607
2475=item $player_object->leave_link ($map, $x, $y) 2608=item $player_object->leave_link ($map, $x, $y)
… …
2496sub cf::object::player::enter_link { 2629sub cf::object::player::enter_link {
2497 my ($self) = @_; 2630 my ($self) = @_;
2498 2631
2499 $self->deactivate_recursive; 2632 $self->deactivate_recursive;
2500 2633
2634 ++$self->{_link_recursion};
2635
2501 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2636 return if UNIVERSAL::isa $self->map, "ext::map_link";
2502 2637
2503 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2638 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2504 if $self->map && $self->map->{path} ne "{link}"; 2639 if $self->map && $self->map->{path} ne "{link}";
2505 2640
2506 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2641 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2507} 2642}
2508 2643
2509sub cf::object::player::leave_link { 2644sub cf::object::player::leave_link {
2510 my ($self, $map, $x, $y) = @_; 2645 my ($self, $map, $x, $y) = @_;
2511 2646
… …
2528 ($x, $y) = (-1, -1) 2663 ($x, $y) = (-1, -1)
2529 unless (defined $x) && (defined $y); 2664 unless (defined $x) && (defined $y);
2530 2665
2531 # use -1 or undef as default coordinates, not 0, 0 2666 # use -1 or undef as default coordinates, not 0, 0
2532 ($x, $y) = ($map->enter_x, $map->enter_y) 2667 ($x, $y) = ($map->enter_x, $map->enter_y)
2533 if $x <=0 && $y <= 0; 2668 if $x <= 0 && $y <= 0;
2534 2669
2535 $map->load; 2670 $map->load;
2536 $map->load_neighbours; 2671 $map->load_neighbours;
2537 2672
2538 return unless $self->contr->active; 2673 return unless $self->contr->active;
2539 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2540 $self->activate_recursive;
2541 2674
2542 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2675 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2543 $self->enter_map ($map, $x, $y); 2676 if ($self->enter_map ($map, $x, $y)) {
2544} 2677 # entering was successful
2678 delete $self->{_link_recursion};
2679 # only activate afterwards, to support waiting in hooks
2680 $self->activate_recursive;
2681 }
2545 2682
2683}
2684
2546=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)]])
2547 2686
2548Moves 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
2549her, loading and preparing them map, calling the provided $check callback 2688her, loading and preparing them map, calling the provided $check callback
2550that 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
2551the 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
… …
2558 2697
2559our $GOTOGEN; 2698our $GOTOGEN;
2560 2699
2561sub cf::object::player::goto { 2700sub cf::object::player::goto {
2562 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 }
2563 2708
2564 # 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
2565 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2710 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2566 2711
2567 $self->enter_link; 2712 $self->enter_link;
… …
2591 my $map = eval { 2736 my $map = eval {
2592 my $map = defined $path ? cf::map::find $path : undef; 2737 my $map = defined $path ? cf::map::find $path : undef;
2593 2738
2594 if ($map) { 2739 if ($map) {
2595 $map = $map->customise_for ($self); 2740 $map = $map->customise_for ($self);
2596 $map = $check->($map) if $check && $map; 2741 $map = $check->($map, $x, $y, $self) if $check && $map;
2597 } else { 2742 } else {
2598 $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);
2599 } 2744 }
2600 2745
2601 $map 2746 $map
… …
2609 if ($gen == $self->{_goto_generation}) { 2754 if ($gen == $self->{_goto_generation}) {
2610 delete $self->{_goto_generation}; 2755 delete $self->{_goto_generation};
2611 $self->leave_link ($map, $x, $y); 2756 $self->leave_link ($map, $x, $y);
2612 } 2757 }
2613 2758
2614 $done->() if $done; 2759 $done->($self) if $done;
2615 })->prio (1); 2760 })->prio (1);
2616} 2761}
2617 2762
2618=item $player_object->enter_exit ($exit_object) 2763=item $player_object->enter_exit ($exit_object)
2619 2764
… …
2712 $self->message ("Something went wrong deep within the deliantra server. " 2857 $self->message ("Something went wrong deep within the deliantra server. "
2713 . "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. "
2714 . "Please report this to the dungeon master!", 2859 . "Please report this to the dungeon master!",
2715 cf::NDI_UNIQUE | cf::NDI_RED); 2860 cf::NDI_UNIQUE | cf::NDI_RED);
2716 2861
2717 warn "ERROR in enter_exit: $@"; 2862 error "ERROR in enter_exit: $@";
2718 $self->leave_link; 2863 $self->leave_link;
2719 } 2864 }
2720 })->prio (1); 2865 })->prio (1);
2721} 2866}
2722 2867
… …
2734sub cf::client::send_drawinfo { 2879sub cf::client::send_drawinfo {
2735 my ($self, $text, $flags) = @_; 2880 my ($self, $text, $flags) = @_;
2736 2881
2737 utf8::encode $text; 2882 utf8::encode $text;
2738 $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);
2739} 2909}
2740 2910
2741=item $client->send_msg ($channel, $msg, $color, [extra...]) 2911=item $client->send_msg ($channel, $msg, $color, [extra...])
2742 2912
2743Send 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
… …
2747 2917
2748=cut 2918=cut
2749 2919
2750# non-persistent channels (usually the info channel) 2920# non-persistent channels (usually the info channel)
2751our %CHANNEL = ( 2921our %CHANNEL = (
2922 "c/motd" => {
2923 id => "infobox",
2924 title => "MOTD",
2925 reply => undef,
2926 tooltip => "The message of the day",
2927 },
2752 "c/identify" => { 2928 "c/identify" => {
2753 id => "infobox", 2929 id => "infobox",
2754 title => "Identify", 2930 title => "Identify",
2755 reply => undef, 2931 reply => undef,
2756 tooltip => "Items recently identified", 2932 tooltip => "Items recently identified",
… …
2758 "c/examine" => { 2934 "c/examine" => {
2759 id => "infobox", 2935 id => "infobox",
2760 title => "Examine", 2936 title => "Examine",
2761 reply => undef, 2937 reply => undef,
2762 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",
2763 }, 2945 },
2764 "c/book" => { 2946 "c/book" => {
2765 id => "infobox", 2947 id => "infobox",
2766 title => "Book", 2948 title => "Book",
2767 reply => undef, 2949 reply => undef,
… …
2883 my $pkt = "msg " 3065 my $pkt = "msg "
2884 . $self->{json_coder}->encode ( 3066 . $self->{json_coder}->encode (
2885 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3067 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2886 ); 3068 );
2887 3069
2888 # try lzf for large packets
2889 $pkt = "lzf " . Compress::LZF::compress $pkt
2890 if 1024 <= length $pkt and $self->{can_lzf};
2891
2892 # split very large packets
2893 if (8192 < length $pkt and $self->{can_lzf}) {
2894 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2895 $pkt = "frag";
2896 }
2897
2898 $self->send_packet ($pkt); 3070 $self->send_big_packet ($pkt);
2899} 3071}
2900 3072
2901=item $client->ext_msg ($type, @msg) 3073=item $client->ext_msg ($type, @msg)
2902 3074
2903Sends an ext event to the client. 3075Sends an ext event to the client.
… …
2906 3078
2907sub cf::client::ext_msg($$@) { 3079sub cf::client::ext_msg($$@) {
2908 my ($self, $type, @msg) = @_; 3080 my ($self, $type, @msg) = @_;
2909 3081
2910 if ($self->extcmd == 2) { 3082 if ($self->extcmd == 2) {
2911 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3083 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2912 } elsif ($self->extcmd == 1) { # TODO: remove 3084 } elsif ($self->extcmd == 1) { # TODO: remove
2913 push @msg, msgtype => "event_$type"; 3085 push @msg, msgtype => "event_$type";
2914 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3086 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2915 } 3087 }
2916} 3088}
2917 3089
2918=item $client->ext_reply ($msgid, @msg) 3090=item $client->ext_reply ($msgid, @msg)
2919 3091
… …
2923 3095
2924sub cf::client::ext_reply($$@) { 3096sub cf::client::ext_reply($$@) {
2925 my ($self, $id, @msg) = @_; 3097 my ($self, $id, @msg) = @_;
2926 3098
2927 if ($self->extcmd == 2) { 3099 if ($self->extcmd == 2) {
2928 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3100 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2929 } elsif ($self->extcmd == 1) { 3101 } elsif ($self->extcmd == 1) {
2930 #TODO: version 1, remove 3102 #TODO: version 1, remove
2931 unshift @msg, msgtype => "reply", msgid => $id; 3103 unshift @msg, msgtype => "reply", msgid => $id;
2932 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3104 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2933 } 3105 }
2934} 3106}
2935 3107
2936=item $success = $client->query ($flags, "text", \&cb) 3108=item $success = $client->query ($flags, "text", \&cb)
2937 3109
… …
3008 3180
3009 $ns->ext_reply ($reply, @reply) 3181 $ns->ext_reply ($reply, @reply)
3010 if $reply; 3182 if $reply;
3011 3183
3012 } else { 3184 } else {
3013 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";
3014 } 3186 }
3015 3187
3016 cf::override; 3188 cf::override;
3017 }, 3189 },
3018); 3190);
… …
3038 3210
3039 $coro 3211 $coro
3040} 3212}
3041 3213
3042cf::client->attach ( 3214cf::client->attach (
3043 on_destroy => sub { 3215 on_client_destroy => sub {
3044 my ($ns) = @_; 3216 my ($ns) = @_;
3045 3217
3046 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3218 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3047 }, 3219 },
3048); 3220);
… …
3064our $safe_hole = new Safe::Hole; 3236our $safe_hole = new Safe::Hole;
3065 3237
3066$SIG{FPE} = 'IGNORE'; 3238$SIG{FPE} = 'IGNORE';
3067 3239
3068$safe->permit_only (Opcode::opset qw( 3240$safe->permit_only (Opcode::opset qw(
3069 :base_core :base_mem :base_orig :base_math 3241 :base_core :base_mem :base_orig :base_math :base_loop
3070 grepstart grepwhile mapstart mapwhile 3242 grepstart grepwhile mapstart mapwhile
3071 sort time 3243 sort time
3072)); 3244));
3073 3245
3074# here we export the classes and methods available to script code 3246# here we export the classes and methods available to script code
… …
3099 decrease split destroy change_exp value msg lore send_msg)], 3271 decrease split destroy change_exp value msg lore send_msg)],
3100 ["cf::object::player" => qw(player)], 3272 ["cf::object::player" => qw(player)],
3101 ["cf::player" => qw(peaceful send_msg)], 3273 ["cf::player" => qw(peaceful send_msg)],
3102 ["cf::map" => qw(trigger)], 3274 ["cf::map" => qw(trigger)],
3103) { 3275) {
3104 no strict 'refs';
3105 my ($pkg, @funs) = @$_; 3276 my ($pkg, @funs) = @$_;
3106 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3277 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3107 for @funs; 3278 for @funs;
3108} 3279}
3109 3280
… …
3126 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3297 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3127 $qcode =~ s/\n/\\n/g; 3298 $qcode =~ s/\n/\\n/g;
3128 3299
3129 %vars = (_dummy => 0) unless %vars; 3300 %vars = (_dummy => 0) unless %vars;
3130 3301
3302 my @res;
3131 local $_; 3303 local $_;
3132 local @safe::cf::_safe_eval_args = values %vars;
3133 3304
3134 my $eval = 3305 my $eval =
3135 "do {\n" 3306 "do {\n"
3136 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3307 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3137 . "#line 0 \"{$qcode}\"\n" 3308 . "#line 0 \"{$qcode}\"\n"
3138 . $code 3309 . $code
3139 . "\n}" 3310 . "\n}"
3140 ; 3311 ;
3141 3312
3313 if ($CFG{safe_eval}) {
3142 sub_generation_inc; 3314 sub_generation_inc;
3315 local @safe::cf::_safe_eval_args = values %vars;
3143 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3316 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3144 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 }
3145 3322
3146 if ($@) { 3323 if ($@) {
3147 warn "$@"; 3324 warn "$@",
3148 warn "while executing safe code '$code'\n"; 3325 "while executing safe code '$code'\n",
3149 warn "with arguments " . (join " ", %vars) . "\n"; 3326 "with arguments " . (join " ", %vars) . "\n";
3150 } 3327 }
3151 3328
3152 wantarray ? @res : $res[0] 3329 wantarray ? @res : $res[0]
3153} 3330}
3154 3331
… …
3168=cut 3345=cut
3169 3346
3170sub register_script_function { 3347sub register_script_function {
3171 my ($fun, $cb) = @_; 3348 my ($fun, $cb) = @_;
3172 3349
3173 no strict 'refs'; 3350 $fun = "safe::$fun" if $CFG{safe_eval};
3174 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3351 *$fun = $safe_hole->wrap ($cb);
3175} 3352}
3176 3353
3177=back 3354=back
3178 3355
3179=cut 3356=cut
… …
3188 # for this (global event?) 3365 # for this (global event?)
3189 %ext::player_env::MUSIC_FACE_CACHE = (); 3366 %ext::player_env::MUSIC_FACE_CACHE = ();
3190 3367
3191 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3368 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3192 3369
3193 warn "loading facedata from $path\n"; 3370 trace "loading facedata from $path\n";
3194 3371
3195 my $facedata; 3372 my $facedata;
3196 0 < aio_load $path, $facedata 3373 0 < aio_load $path, $facedata
3197 or die "$path: $!"; 3374 or die "$path: $!";
3198 3375
… …
3200 3377
3201 $facedata->{version} == 2 3378 $facedata->{version} == 2
3202 or cf::cleanup "$path: version mismatch, cannot proceed."; 3379 or cf::cleanup "$path: version mismatch, cannot proceed.";
3203 3380
3204 # 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]);
3205 $facedata->{resource}{"res/exp_table"} = { 3383 $facedata->{resource}{"res/exp_table"} = {
3206 type => FT_RSRC, 3384 type => FT_RSRC,
3207 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),
3208 }; 3387 };
3209 cf::cede_to_tick; 3388 cf::cede_to_tick;
3210 3389
3211 { 3390 {
3212 my $faces = $facedata->{faceinfo}; 3391 my $faces = $facedata->{faceinfo};
… …
3214 while (my ($face, $info) = each %$faces) { 3393 while (my ($face, $info) = each %$faces) {
3215 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3394 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3216 3395
3217 cf::face::set_visibility $idx, $info->{visibility}; 3396 cf::face::set_visibility $idx, $info->{visibility};
3218 cf::face::set_magicmap $idx, $info->{magicmap}; 3397 cf::face::set_magicmap $idx, $info->{magicmap};
3219 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3398 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3220 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3399 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3221 3400
3222 cf::cede_to_tick; 3401 cf::cede_to_tick;
3223 } 3402 }
3224 3403
3225 while (my ($face, $info) = each %$faces) { 3404 while (my ($face, $info) = each %$faces) {
… …
3230 3409
3231 if (my $smooth = cf::face::find $info->{smooth}) { 3410 if (my $smooth = cf::face::find $info->{smooth}) {
3232 cf::face::set_smooth $idx, $smooth; 3411 cf::face::set_smooth $idx, $smooth;
3233 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3412 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3234 } else { 3413 } else {
3235 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3414 error "smooth face '$info->{smooth}' not found for face '$face'";
3236 } 3415 }
3237 3416
3238 cf::cede_to_tick; 3417 cf::cede_to_tick;
3239 } 3418 }
3240 } 3419 }
… …
3249 3428
3250 cf::anim::invalidate_all; # d'oh 3429 cf::anim::invalidate_all; # d'oh
3251 } 3430 }
3252 3431
3253 { 3432 {
3254 # TODO: for gcfclient pleasure, we should give resources
3255 # that gcfclient doesn't grok a >10000 face index.
3256 my $res = $facedata->{resource}; 3433 my $res = $facedata->{resource};
3257 3434
3258 while (my ($name, $info) = each %$res) { 3435 while (my ($name, $info) = each %$res) {
3259 if (defined $info->{type}) { 3436 if (defined $info->{type}) {
3260 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3437 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3261 my $data;
3262 3438
3263 if ($info->{type} & 1) { 3439 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3264 # prepend meta info
3265
3266 my $meta = $enc->encode ({
3267 name => $name,
3268 %{ $info->{meta} || {} },
3269 });
3270
3271 $data = pack "(w/a*)*", $meta, $info->{data};
3272 } else {
3273 $data = $info->{data};
3274 }
3275
3276 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3277 cf::face::set_type $idx, $info->{type}; 3440 cf::face::set_type $idx, $info->{type};
3278 } else { 3441 } else {
3279 $RESOURCE{$name} = $info; 3442 $RESOURCE{$name} = $info; # unused
3280 } 3443 }
3281 3444
3282 cf::cede_to_tick; 3445 cf::cede_to_tick;
3283 } 3446 }
3284 } 3447 }
3285 3448
3286 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3449 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3287 3450
3288 1 3451 1
3289} 3452}
3290
3291cf::global->attach (on_resource_update => sub {
3292 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3293 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3294
3295 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3296 my $sound = $soundconf->{compat}[$_]
3297 or next;
3298
3299 my $face = cf::face::find "sound/$sound->[1]";
3300 cf::sound::set $sound->[0] => $face;
3301 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3302 }
3303
3304 while (my ($k, $v) = each %{$soundconf->{event}}) {
3305 my $face = cf::face::find "sound/$v";
3306 cf::sound::set $k => $face;
3307 }
3308 }
3309});
3310 3453
3311register_exticmd fx_want => sub { 3454register_exticmd fx_want => sub {
3312 my ($ns, $want) = @_; 3455 my ($ns, $want) = @_;
3313 3456
3314 while (my ($k, $v) = each %$want) { 3457 while (my ($k, $v) = each %$want) {
… …
3353sub reload_treasures { 3496sub reload_treasures {
3354 load_resource_file "$DATADIR/treasures" 3497 load_resource_file "$DATADIR/treasures"
3355 or die "unable to load treasurelists\n"; 3498 or die "unable to load treasurelists\n";
3356} 3499}
3357 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
3358sub reload_resources { 3524sub reload_resources {
3359 warn "reloading resource files...\n"; 3525 trace "reloading resource files...\n";
3360 3526
3361 reload_facedata; 3527 reload_facedata;
3528 reload_sound;
3362 reload_archetypes; 3529 reload_archetypes;
3363 reload_regions; 3530 reload_regions;
3364 reload_treasures; 3531 reload_treasures;
3365 3532
3366 warn "finished reloading resource files\n"; 3533 trace "finished reloading resource files\n";
3367} 3534}
3368 3535
3369sub reload_config { 3536sub reload_config {
3537 trace "reloading config file...\n";
3538
3370 open my $fh, "<:utf8", "$CONFDIR/config" 3539 open my $fh, "<:utf8", "$CONFDIR/config"
3371 or return; 3540 or return;
3372 3541
3373 local $/; 3542 local $/;
3374 *CFG = YAML::Load <$fh>; 3543 *CFG = YAML::XS::Load scalar <$fh>;
3375 3544
3376 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3545 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3377 3546
3378 $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};
3379 $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};
3380 3549
3381 if (exists $CFG{mlockall}) { 3550 if (exists $CFG{mlockall}) {
… …
3383 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3552 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3384 and die "WARNING: m(un)lockall failed: $!\n"; 3553 and die "WARNING: m(un)lockall failed: $!\n";
3385 }; 3554 };
3386 warn $@ if $@; 3555 warn $@ if $@;
3387 } 3556 }
3557
3558 trace "finished reloading resource files\n";
3388} 3559}
3389 3560
3390sub pidfile() { 3561sub pidfile() {
3391 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3562 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3392 or die "$PIDFILE: $!"; 3563 or die "$PIDFILE: $!";
… …
3405 seek $fh, 0, 0; 3576 seek $fh, 0, 0;
3406 print $fh $$; 3577 print $fh $$;
3407} 3578}
3408 3579
3409sub main_loop { 3580sub main_loop {
3410 warn "EV::loop starting\n"; 3581 trace "EV::loop starting\n";
3411 if (1) { 3582 if (1) {
3412 EV::loop; 3583 EV::loop;
3413 } 3584 }
3414 warn "EV::loop returned\n"; 3585 trace "EV::loop returned\n";
3415 goto &main_loop unless $REALLY_UNLOOP; 3586 goto &main_loop unless $REALLY_UNLOOP;
3416} 3587}
3417 3588
3418sub main { 3589sub main {
3419 cf::init_globals; # initialise logging 3590 cf::init_globals; # initialise logging
3420 3591
3421 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3592 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3422 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.";
3423 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3594 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3424 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3595 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3425
3426 cf::init_experience;
3427 cf::init_anim;
3428 cf::init_attackmess;
3429 cf::init_dynamic;
3430 3596
3431 $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
3432 3598
3433 # we must not ever block the main coroutine 3599 # we must not ever block the main coroutine
3434 local $Coro::idle = sub { 3600 local $Coro::idle = sub {
… …
3440 }; 3606 };
3441 3607
3442 evthread_start IO::AIO::poll_fileno; 3608 evthread_start IO::AIO::poll_fileno;
3443 3609
3444 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
3445 reload_resources; 3619 reload_resources;
3446 reload_config; 3620 reload_config;
3447 db_init; 3621 db_init;
3448 3622
3449 cf::load_settings;
3450 cf::load_materials;
3451 cf::init_uuid; 3623 cf::init_uuid;
3452 cf::init_signals; 3624 cf::init_signals;
3453 cf::init_commands;
3454 cf::init_skills; 3625 cf::init_skills;
3455 3626
3456 cf::init_beforeplay; 3627 cf::init_beforeplay;
3457 3628
3458 atomic; 3629 atomic;
… …
3465 use POSIX (); 3636 use POSIX ();
3466 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};
3467 3638
3468 (pop @POST_INIT)->(0) while @POST_INIT; 3639 (pop @POST_INIT)->(0) while @POST_INIT;
3469 }; 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";
3470 3644
3471 main_loop; 3645 main_loop;
3472} 3646}
3473 3647
3474############################################################################# 3648#############################################################################
… …
3476 3650
3477# install some emergency cleanup handlers 3651# install some emergency cleanup handlers
3478BEGIN { 3652BEGIN {
3479 our %SIGWATCHER = (); 3653 our %SIGWATCHER = ();
3480 for my $signal (qw(INT HUP TERM)) { 3654 for my $signal (qw(INT HUP TERM)) {
3481 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3655 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3482 cf::cleanup "SIG$signal"; 3656 cf::cleanup "SIG$signal";
3483 }; 3657 };
3484 } 3658 }
3485} 3659}
3486 3660
3487sub write_runtime_sync { 3661sub write_runtime_sync {
3662 my $t0 = AE::time;
3663
3488 # first touch the runtime file to show we are still running: 3664 # first touch the runtime file to show we are still running:
3489 # the fsync below can take a very very long time. 3665 # the fsync below can take a very very long time.
3490 3666
3491 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3667 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3492 3668
3493 my $guard = cf::lock_acquire "write_runtime"; 3669 my $guard = cf::lock_acquire "write_runtime";
3494 3670
3495 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3671 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3496 or return; 3672 or return;
3497 3673
3498 my $value = $cf::RUNTIME + 90 + 10; 3674 my $value = $cf::RUNTIME + 90 + 10;
3499 # 10 is the runtime save interval, for a monotonic clock 3675 # 10 is the runtime save interval, for a monotonic clock
3500 # 60 allows for the watchdog to kill the server. 3676 # 60 allows for the watchdog to kill the server.
… …
3513 or return; 3689 or return;
3514 3690
3515 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3691 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3516 and return; 3692 and return;
3517 3693
3518 warn "runtime file written.\n"; 3694 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3519 3695
3520 1 3696 1
3521} 3697}
3522 3698
3523our $uuid_lock; 3699our $uuid_lock;
… …
3535 or return; 3711 or return;
3536 3712
3537 my $value = uuid_seq uuid_cur; 3713 my $value = uuid_seq uuid_cur;
3538 3714
3539 unless ($value) { 3715 unless ($value) {
3540 warn "cowardly refusing to write zero uuid value!\n"; 3716 info "cowardly refusing to write zero uuid value!\n";
3541 return; 3717 return;
3542 } 3718 }
3543 3719
3544 my $value = uuid_str $value + $uuid_skip; 3720 my $value = uuid_str $value + $uuid_skip;
3545 $uuid_skip = 0; 3721 $uuid_skip = 0;
… …
3555 or return; 3731 or return;
3556 3732
3557 aio_rename "$uuid~", $uuid 3733 aio_rename "$uuid~", $uuid
3558 and return; 3734 and return;
3559 3735
3560 warn "uuid file written ($value).\n"; 3736 trace "uuid file written ($value).\n";
3561 3737
3562 1 3738 1
3563 3739
3564} 3740}
3565 3741
… …
3571} 3747}
3572 3748
3573sub emergency_save() { 3749sub emergency_save() {
3574 my $freeze_guard = cf::freeze_mainloop; 3750 my $freeze_guard = cf::freeze_mainloop;
3575 3751
3576 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;
3577 3758
3578 cf::sync_job { 3759 cf::sync_job {
3579 # this is a trade-off: we want to be very quick here, so 3760 cf::write_runtime_sync; # external watchdog should not bark
3580 # save all maps without fsync, and later call a global sync
3581 # (which in turn might be very very slow)
3582 local $USE_FSYNC = 0;
3583 3761
3584 # use a peculiar iteration method to avoid tripping on perl 3762 # use a peculiar iteration method to avoid tripping on perl
3585 # refcount bugs in for. also avoids problems with players 3763 # refcount bugs in for. also avoids problems with players
3586 # and maps saved/destroyed asynchronously. 3764 # and maps saved/destroyed asynchronously.
3587 warn "emergency_perl_save: begin player save\n"; 3765 info "emergency_perl_save: begin player save\n";
3588 for my $login (keys %cf::PLAYER) { 3766 for my $login (keys %cf::PLAYER) {
3589 my $pl = $cf::PLAYER{$login} or next; 3767 my $pl = $cf::PLAYER{$login} or next;
3590 $pl->valid or next; 3768 $pl->valid or next;
3591 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3769 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3592 $pl->save; 3770 $pl->save;
3593 } 3771 }
3594 warn "emergency_perl_save: end player save\n"; 3772 info "emergency_perl_save: end player save\n";
3595 3773
3774 cf::write_runtime_sync; # external watchdog should not bark
3775
3596 warn "emergency_perl_save: begin map save\n"; 3776 info "emergency_perl_save: begin map save\n";
3597 for my $path (keys %cf::MAP) { 3777 for my $path (keys %cf::MAP) {
3598 my $map = $cf::MAP{$path} or next; 3778 my $map = $cf::MAP{$path} or next;
3599 $map->valid or next; 3779 $map->valid or next;
3600 $map->save; 3780 $map->save;
3601 } 3781 }
3602 warn "emergency_perl_save: end map save\n"; 3782 info "emergency_perl_save: end map save\n";
3603 3783
3784 cf::write_runtime_sync; # external watchdog should not bark
3785
3604 warn "emergency_perl_save: begin database checkpoint\n"; 3786 info "emergency_perl_save: begin database checkpoint\n";
3605 BDB::db_env_txn_checkpoint $DB_ENV; 3787 BDB::db_env_txn_checkpoint $DB_ENV;
3606 warn "emergency_perl_save: end database checkpoint\n"; 3788 info "emergency_perl_save: end database checkpoint\n";
3607 3789
3608 warn "emergency_perl_save: begin write uuid\n"; 3790 info "emergency_perl_save: begin write uuid\n";
3609 write_uuid_sync 1; 3791 write_uuid_sync 1;
3610 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
3611 }; 3812 };
3612 3813
3613 warn "emergency_perl_save: starting sync()\n";
3614 IO::AIO::aio_sync sub {
3615 warn "emergency_perl_save: finished sync()\n";
3616 };
3617
3618 warn "emergency_perl_save: leave\n"; 3814 info "emergency_perl_save: leave\n";
3619} 3815}
3620 3816
3621sub post_cleanup { 3817sub post_cleanup {
3622 my ($make_core) = @_; 3818 my ($make_core) = @_;
3623 3819
3820 IO::AIO::flush;
3821
3624 warn Carp::longmess "post_cleanup backtrace" 3822 error Carp::longmess "post_cleanup backtrace"
3625 if $make_core; 3823 if $make_core;
3626 3824
3627 my $fh = pidfile; 3825 my $fh = pidfile;
3628 unlink $PIDFILE if <$fh> == $$; 3826 unlink $PIDFILE if <$fh> == $$;
3629} 3827}
… …
3649 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3847 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3650 for my $name (keys %$leaf_symtab) { 3848 for my $name (keys %$leaf_symtab) {
3651 _gv_clear *{"$pkg$name"}; 3849 _gv_clear *{"$pkg$name"};
3652# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3850# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3653 } 3851 }
3654 warn "cleared package $pkg\n";#d#
3655} 3852}
3656 3853
3657sub do_reload_perl() { 3854sub do_reload_perl() {
3658 # can/must only be called in main 3855 # can/must only be called in main
3659 if ($Coro::current != $Coro::main) { 3856 if (in_main) {
3660 warn "can only reload from main coroutine"; 3857 error "can only reload from main coroutine";
3661 return; 3858 return;
3662 } 3859 }
3663 3860
3664 return if $RELOAD++; 3861 return if $RELOAD++;
3665 3862
3666 my $t1 = EV::time; 3863 my $t1 = AE::time;
3667 3864
3668 while ($RELOAD) { 3865 while ($RELOAD) {
3669 warn "reloading..."; 3866 info "reloading...";
3670 3867
3671 warn "entering sync_job"; 3868 trace "entering sync_job";
3672 3869
3673 cf::sync_job { 3870 cf::sync_job {
3674 cf::write_runtime_sync; # external watchdog should not bark
3675 cf::emergency_save; 3871 cf::emergency_save;
3676 cf::write_runtime_sync; # external watchdog should not bark
3677 3872
3678 warn "syncing database to disk";
3679 BDB::db_env_txn_checkpoint $DB_ENV;
3680
3681 # if anything goes wrong in here, we should simply crash as we already saved
3682
3683 warn "flushing outstanding aio requests";
3684 while (IO::AIO::nreqs || BDB::nreqs) {
3685 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3686 }
3687
3688 warn "cancelling all extension coros"; 3873 trace "cancelling all extension coros";
3689 $_->cancel for values %EXT_CORO; 3874 $_->cancel for values %EXT_CORO;
3690 %EXT_CORO = (); 3875 %EXT_CORO = ();
3691 3876
3692 warn "removing commands"; 3877 trace "removing commands";
3693 %COMMAND = (); 3878 %COMMAND = ();
3694 3879
3695 warn "removing ext/exti commands"; 3880 trace "removing ext/exti commands";
3696 %EXTCMD = (); 3881 %EXTCMD = ();
3697 %EXTICMD = (); 3882 %EXTICMD = ();
3698 3883
3699 warn "unloading/nuking all extensions"; 3884 trace "unloading/nuking all extensions";
3700 for my $pkg (@EXTS) { 3885 for my $pkg (@EXTS) {
3701 warn "... unloading $pkg"; 3886 trace "... unloading $pkg";
3702 3887
3703 if (my $cb = $pkg->can ("unload")) { 3888 if (my $cb = $pkg->can ("unload")) {
3704 eval { 3889 eval {
3705 $cb->($pkg); 3890 $cb->($pkg);
3706 1 3891 1
3707 } or warn "$pkg unloaded, but with errors: $@"; 3892 } or error "$pkg unloaded, but with errors: $@";
3708 } 3893 }
3709 3894
3710 warn "... clearing $pkg"; 3895 trace "... clearing $pkg";
3711 clear_package $pkg; 3896 clear_package $pkg;
3712 } 3897 }
3713 3898
3714 warn "unloading all perl modules loaded from $LIBDIR"; 3899 trace "unloading all perl modules loaded from $LIBDIR";
3715 while (my ($k, $v) = each %INC) { 3900 while (my ($k, $v) = each %INC) {
3716 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3901 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3717 3902
3718 warn "... unloading $k"; 3903 trace "... unloading $k";
3719 delete $INC{$k}; 3904 delete $INC{$k};
3720 3905
3721 $k =~ s/\.pm$//; 3906 $k =~ s/\.pm$//;
3722 $k =~ s/\//::/g; 3907 $k =~ s/\//::/g;
3723 3908
… …
3726 } 3911 }
3727 3912
3728 clear_package $k; 3913 clear_package $k;
3729 } 3914 }
3730 3915
3731 warn "getting rid of safe::, as good as possible"; 3916 trace "getting rid of safe::, as good as possible";
3732 clear_package "safe::$_" 3917 clear_package "safe::$_"
3733 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);
3734 3919
3735 warn "unloading cf.pm \"a bit\""; 3920 trace "unloading cf.pm \"a bit\"";
3736 delete $INC{"cf.pm"}; 3921 delete $INC{"cf.pm"};
3737 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 3922 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3738 3923
3739 # don't, removes xs symbols, too, 3924 # don't, removes xs symbols, too,
3740 # and global variables created in xs 3925 # and global variables created in xs
3741 #clear_package __PACKAGE__; 3926 #clear_package __PACKAGE__;
3742 3927
3743 warn "unload completed, starting to reload now"; 3928 info "unload completed, starting to reload now";
3744 3929
3745 warn "reloading cf.pm"; 3930 trace "reloading cf.pm";
3746 require cf; 3931 require cf;
3747 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3932 cf::_connect_to_perl_1;
3748 3933
3749 warn "loading config and database again"; 3934 trace "loading config and database again";
3750 cf::reload_config; 3935 cf::reload_config;
3751 3936
3752 warn "loading extensions"; 3937 trace "loading extensions";
3753 cf::load_extensions; 3938 cf::load_extensions;
3754 3939
3755 if ($REATTACH_ON_RELOAD) { 3940 if ($REATTACH_ON_RELOAD) {
3756 warn "reattaching attachments to objects/players"; 3941 trace "reattaching attachments to objects/players";
3757 _global_reattach; # objects, sockets 3942 _global_reattach; # objects, sockets
3758 warn "reattaching attachments to maps"; 3943 trace "reattaching attachments to maps";
3759 reattach $_ for values %MAP; 3944 reattach $_ for values %MAP;
3760 warn "reattaching attachments to players"; 3945 trace "reattaching attachments to players";
3761 reattach $_ for values %PLAYER; 3946 reattach $_ for values %PLAYER;
3762 } 3947 }
3763 3948
3764 warn "running post_init jobs"; 3949 trace "running post_init jobs";
3765 (pop @POST_INIT)->(1) while @POST_INIT; 3950 (pop @POST_INIT)->(1) while @POST_INIT;
3766 3951
3767 warn "leaving sync_job"; 3952 trace "leaving sync_job";
3768 3953
3769 1 3954 1
3770 } or do { 3955 } or do {
3771 warn $@; 3956 error $@;
3772 cf::cleanup "error while reloading, exiting."; 3957 cf::cleanup "error while reloading, exiting.";
3773 }; 3958 };
3774 3959
3775 warn "reloaded"; 3960 info "reloaded";
3776 --$RELOAD; 3961 --$RELOAD;
3777 } 3962 }
3778 3963
3779 $t1 = EV::time - $t1; 3964 $t1 = AE::time - $t1;
3780 warn "reload completed in ${t1}s\n"; 3965 info "reload completed in ${t1}s\n";
3781}; 3966};
3782 3967
3783our $RELOAD_WATCHER; # used only during reload 3968our $RELOAD_WATCHER; # used only during reload
3784 3969
3785sub reload_perl() { 3970sub reload_perl() {
… …
3787 # coro crashes during coro_state_free->destroy here. 3972 # coro crashes during coro_state_free->destroy here.
3788 3973
3789 $RELOAD_WATCHER ||= cf::async { 3974 $RELOAD_WATCHER ||= cf::async {
3790 Coro::AIO::aio_wait cache_extensions; 3975 Coro::AIO::aio_wait cache_extensions;
3791 3976
3792 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 3977 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3793 do_reload_perl; 3978 do_reload_perl;
3794 undef $RELOAD_WATCHER; 3979 undef $RELOAD_WATCHER;
3795 }; 3980 };
3796 }; 3981 };
3797} 3982}
… …
3814 3999
3815our @WAIT_FOR_TICK; 4000our @WAIT_FOR_TICK;
3816our @WAIT_FOR_TICK_BEGIN; 4001our @WAIT_FOR_TICK_BEGIN;
3817 4002
3818sub wait_for_tick { 4003sub wait_for_tick {
3819 return if tick_inhibit || $Coro::current == $Coro::main; 4004 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3820 4005
3821 my $signal = new Coro::Signal; 4006 my $signal = new Coro::Signal;
3822 push @WAIT_FOR_TICK, $signal; 4007 push @WAIT_FOR_TICK, $signal;
3823 $signal->wait; 4008 $signal->wait;
3824} 4009}
3825 4010
3826sub wait_for_tick_begin { 4011sub wait_for_tick_begin {
3827 return if tick_inhibit || $Coro::current == $Coro::main; 4012 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3828 4013
3829 my $signal = new Coro::Signal; 4014 my $signal = new Coro::Signal;
3830 push @WAIT_FOR_TICK_BEGIN, $signal; 4015 push @WAIT_FOR_TICK_BEGIN, $signal;
3831 $signal->wait; 4016 $signal->wait;
3832} 4017}
… …
3838 return; 4023 return;
3839 } 4024 }
3840 4025
3841 cf::server_tick; # one server iteration 4026 cf::server_tick; # one server iteration
3842 4027
4028 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4029
3843 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4030 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3844 $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.;
3845 Coro::async_pool { 4032 Coro::async_pool {
3846 $Coro::current->{desc} = "runtime saver"; 4033 $Coro::current->{desc} = "runtime saver";
3847 write_runtime_sync 4034 write_runtime_sync
3848 or warn "ERROR: unable to write runtime file: $!"; 4035 or error "ERROR: unable to write runtime file: $!";
3849 }; 4036 };
3850 } 4037 }
3851 4038
3852 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4039 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3853 $sig->send; 4040 $sig->send;
… …
3861 4048
3862 if (0) { 4049 if (0) {
3863 if ($NEXT_TICK) { 4050 if ($NEXT_TICK) {
3864 my $jitter = $TICK_START - $NEXT_TICK; 4051 my $jitter = $TICK_START - $NEXT_TICK;
3865 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4052 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3866 warn "jitter $JITTER\n";#d# 4053 debug "jitter $JITTER\n";#d#
3867 } 4054 }
3868 } 4055 }
3869} 4056}
3870 4057
3871{ 4058{
3872 # configure BDB 4059 # configure BDB
3873 4060
3874 BDB::min_parallel 8; 4061 BDB::min_parallel 16;
3875 BDB::max_poll_reqs $TICK * 0.1; 4062 BDB::max_poll_reqs $TICK * 0.1;
3876 $AnyEvent::BDB::WATCHER->priority (1); 4063 $AnyEvent::BDB::WATCHER->priority (1);
3877 4064
3878 unless ($DB_ENV) { 4065 unless ($DB_ENV) {
3879 $DB_ENV = BDB::db_env_create; 4066 $DB_ENV = BDB::db_env_create;
… …
3960 } 4147 }
3961} 4148}
3962 4149
3963# load additional modules 4150# load additional modules
3964require "cf/$_.pm" for @EXTRA_MODULES; 4151require "cf/$_.pm" for @EXTRA_MODULES;
4152cf::_connect_to_perl_2;
3965 4153
3966END { cf::emergency_save } 4154END { cf::emergency_save }
3967 4155
39681 41561
3969 4157

Diff Legend

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