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.480 by root, Thu Oct 8 05:09:43 2009 UTC vs.
Revision 1.533 by root, Thu Apr 29 07:59:17 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 5.10.0;
25use utf8; 26use utf8;
… …
31use EV; 32use EV;
32use Opcode; 33use Opcode;
33use Safe; 34use Safe;
34use Safe::Hole; 35use Safe::Hole;
35use Storable (); 36use Storable ();
37use Carp ();
36 38
37use Guard (); 39use Guard ();
38use Coro (); 40use Coro ();
39use Coro::State; 41use Coro::State;
40use Coro::Handle; 42use Coro::Handle;
… …
51use Coro::Util (); 53use Coro::Util ();
52 54
53use JSON::XS 2.01 (); 55use JSON::XS 2.01 ();
54use BDB (); 56use BDB ();
55use Data::Dumper; 57use Data::Dumper;
56use Digest::MD5;
57use Fcntl; 58use Fcntl;
58use YAML (); 59use YAML::XS ();
59use IO::AIO (); 60use IO::AIO ();
60use Time::HiRes; 61use Time::HiRes;
61use Compress::LZF; 62use Compress::LZF;
62use Digest::MD5 (); 63use Digest::MD5 ();
63 64
… …
105our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
106our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
107our $PIDFILE = "$LOCALDIR/pid"; 108our $PIDFILE = "$LOCALDIR/pid";
108our $RUNTIMEFILE = "$LOCALDIR/runtime"; 109our $RUNTIMEFILE = "$LOCALDIR/runtime";
109 110
110our %RESOURCE; 111our %RESOURCE; # unused
112
113our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 1000000;
115
116our $MAX_LINKS = 32; # how many chained exits to follow
117our $VERBOSE_IO = 1;
111 118
112our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
113our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
114our $NEXT_TICK; 121our $NEXT_TICK;
115our $USE_FSYNC = 1; # use fsync to write maps - default on 122our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
117our $BDB_DEADLOCK_WATCHER; 124our $BDB_DEADLOCK_WATCHER;
118our $BDB_CHECKPOINT_WATCHER; 125our $BDB_CHECKPOINT_WATCHER;
119our $BDB_TRICKLE_WATCHER; 126our $BDB_TRICKLE_WATCHER;
120our $DB_ENV; 127our $DB_ENV;
121 128
122our @EXTRA_MODULES = qw(pod mapscript); 129our @EXTRA_MODULES = qw(pod match mapscript);
123 130
124our %CFG; 131our %CFG;
125 132
126our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
127our $RUNTIME; 134our $RUNTIME;
… …
161 168
162our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
163 170
164sub cf::map::normalise; 171sub cf::map::normalise;
165 172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
176
166############################################################################# 177#############################################################################
167 178
168%REFLECT = (); 179%REFLECT = ();
169for (@REFLECT) { 180for (@REFLECT) {
170 my $reflect = JSON::XS::decode_json $_; 181 my $reflect = JSON::XS::decode_json $_;
171 $REFLECT{$reflect->{class}} = $reflect; 182 $REFLECT{$reflect->{class}} = $reflect;
172} 183}
173 184
174# this is decidedly evil 185# this is decidedly evil
175$REFLECT{object}{flags} = [grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"}]; 186$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
176 187
177############################################################################# 188#############################################################################
178 189
179=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
180 191
… …
227returns directly I<after> the tick processing (and consequently, can only wake one process 238returns directly I<after> the tick processing (and consequently, can only wake one process
228per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 239per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
229 240
230=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
231 242
232This array contains the results of the last C<invoke ()> call. When 243This array contains the results of the last C<invoke ()> call. When
233C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 244C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
234that call. 245that call.
235 246
236=item %cf::REFLECT 247=item %cf::REFLECT
237 248
… …
241 252
242=back 253=back
243 254
244=cut 255=cut
245 256
257sub error(@) { LOG llevError, join "", @_ }
258sub warn (@) { LOG llevWarn , join "", @_ }
259sub info (@) { LOG llevInfo , join "", @_ }
260sub debug(@) { LOG llevDebug, join "", @_ }
261sub trace(@) { LOG llevTrace, join "", @_ }
262
246$Coro::State::WARNHOOK = sub { 263$Coro::State::WARNHOOK = sub {
247 my $msg = join "", @_; 264 my $msg = join "", @_;
248 265
249 $msg .= "\n" 266 $msg .= "\n"
250 unless $msg =~ /\n$/; 267 unless $msg =~ /\n$/;
251 268
252 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 269 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
253 270
254 LOG llevError, $msg; 271 LOG llevWarn, $msg;
255}; 272};
256 273
257$Coro::State::DIEHOOK = sub { 274$Coro::State::DIEHOOK = sub {
258 return unless $^S eq 0; # "eq", not "==" 275 return unless $^S eq 0; # "eq", not "=="
259 276
260 warn Carp::longmess $_[0]; 277 error Carp::longmess $_[0];
261 278
262 if ($Coro::current == $Coro::main) {#d# 279 if (in_main) {#d#
263 warn "DIEHOOK called in main context, Coro bug?\n";#d# 280 error "DIEHOOK called in main context, Coro bug?\n";#d#
264 return;#d# 281 return;#d#
265 }#d# 282 }#d#
266 283
267 # kill coroutine otherwise 284 # kill coroutine otherwise
268 Coro::terminate 285 Coro::terminate
… …
288)) { 305)) {
289 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 306 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
290} 307}
291 308
292$EV::DIED = sub { 309$EV::DIED = sub {
293 warn "error in event callback: @_"; 310 Carp::cluck "error in event callback: @_";
294}; 311};
295 312
296############################################################################# 313#############################################################################
297 314
298=head2 UTILITY FUNCTIONS 315=head2 UTILITY FUNCTIONS
… …
395} 412}
396 413
397=item cf::periodic $interval, $cb 414=item cf::periodic $interval, $cb
398 415
399Like EV::periodic, but randomly selects a starting point so that the actions 416Like EV::periodic, but randomly selects a starting point so that the actions
400get spread over timer. 417get spread over time.
401 418
402=cut 419=cut
403 420
404sub periodic($$) { 421sub periodic($$) {
405 my ($interval, $cb) = @_; 422 my ($interval, $cb) = @_;
… …
422 439
423=cut 440=cut
424 441
425our @SLOT_QUEUE; 442our @SLOT_QUEUE;
426our $SLOT_QUEUE; 443our $SLOT_QUEUE;
444our $SLOT_DECAY = 0.9;
427 445
428$SLOT_QUEUE->cancel if $SLOT_QUEUE; 446$SLOT_QUEUE->cancel if $SLOT_QUEUE;
429$SLOT_QUEUE = Coro::async { 447$SLOT_QUEUE = Coro::async {
430 $Coro::current->desc ("timeslot manager"); 448 $Coro::current->desc ("timeslot manager");
431 449
432 my $signal = new Coro::Signal; 450 my $signal = new Coro::Signal;
451 my $busy;
433 452
434 while () { 453 while () {
435 next_job: 454 next_job:
455
436 my $avail = cf::till_tick; 456 my $avail = cf::till_tick;
437 if ($avail > 0.01) { 457
438 for (0 .. $#SLOT_QUEUE) { 458 for (0 .. $#SLOT_QUEUE) {
439 if ($SLOT_QUEUE[$_][0] < $avail) { 459 if ($SLOT_QUEUE[$_][0] <= $avail) {
460 $busy = 0;
440 my $job = splice @SLOT_QUEUE, $_, 1, (); 461 my $job = splice @SLOT_QUEUE, $_, 1, ();
441 $job->[2]->send; 462 $job->[2]->send;
442 Coro::cede; 463 Coro::cede;
443 goto next_job; 464 goto next_job;
444 } 465 } else {
466 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
445 } 467 }
446 } 468 }
447 469
448 if (@SLOT_QUEUE) { 470 if (@SLOT_QUEUE) {
449 # we do not use wait_for_tick() as it returns immediately when tick is inactive 471 # we do not use wait_for_tick() as it returns immediately when tick is inactive
450 push @cf::WAIT_FOR_TICK, $signal; 472 push @cf::WAIT_FOR_TICK, $signal;
451 $signal->wait; 473 $signal->wait;
452 } else { 474 } else {
475 $busy = 0;
453 Coro::schedule; 476 Coro::schedule;
454 } 477 }
455 } 478 }
456}; 479};
457 480
458sub get_slot($;$$) { 481sub get_slot($;$$) {
459 return if tick_inhibit || $Coro::current == $Coro::main; 482 return if tick_inhibit || $Coro::current == $Coro::main;
460 483
461 my ($time, $pri, $name) = @_; 484 my ($time, $pri, $name) = @_;
462 485
463 $time = $TICK * .6 if $time > $TICK * .6; 486 $time = clamp $time, 0.01, $TICK * .6;
487
464 my $sig = new Coro::Signal; 488 my $sig = new Coro::Signal;
465 489
466 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 490 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
467 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 491 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
468 $SLOT_QUEUE->ready; 492 $SLOT_QUEUE->ready;
… …
495 519
496sub sync_job(&) { 520sub sync_job(&) {
497 my ($job) = @_; 521 my ($job) = @_;
498 522
499 if ($Coro::current == $Coro::main) { 523 if ($Coro::current == $Coro::main) {
500 my $time = EV::time; 524 my $time = AE::time;
501 525
502 # this is the main coro, too bad, we have to block 526 # this is the main coro, too bad, we have to block
503 # till the operation succeeds, freezing the server :/ 527 # till the operation succeeds, freezing the server :/
504 528
505 LOG llevError, Carp::longmess "sync job";#d# 529 LOG llevError, Carp::longmess "sync job";#d#
… …
510 my @res; 534 my @res;
511 535
512 (async { 536 (async {
513 $Coro::current->desc ("sync job coro"); 537 $Coro::current->desc ("sync job coro");
514 @res = eval { $job->() }; 538 @res = eval { $job->() };
515 warn $@ if $@; 539 error $@ if $@;
516 undef $busy; 540 undef $busy;
517 })->prio (Coro::PRIO_MAX); 541 })->prio (Coro::PRIO_MAX);
518 542
519 while ($busy) { 543 while ($busy) {
520 if (Coro::nready) { 544 if (Coro::nready) {
… …
522 } else { 546 } else {
523 EV::loop EV::LOOP_ONESHOT; 547 EV::loop EV::LOOP_ONESHOT;
524 } 548 }
525 } 549 }
526 550
527 my $time = EV::time - $time; 551 my $time = AE::time - $time;
528 552
529 $TICK_START += $time; # do not account sync jobs to server load 553 $TICK_START += $time; # do not account sync jobs to server load
530 554
531 wantarray ? @res : $res[0] 555 wantarray ? @res : $res[0]
532 } else { 556 } else {
… …
576 reset_signals; 600 reset_signals;
577 &$cb 601 &$cb
578 }, @args; 602 }, @args;
579 603
580 wantarray ? @res : $res[-1] 604 wantarray ? @res : $res[-1]
605}
606
607sub objinfo {
608 (
609 "counter value" => cf::object::object_count,
610 "objects created" => cf::object::create_count,
611 "objects destroyed" => cf::object::destroy_count,
612 "freelist size" => cf::object::free_count,
613 "allocated objects" => cf::object::objects_size,
614 "active objects" => cf::object::actives_size,
615 )
581} 616}
582 617
583=item $coin = coin_from_name $name 618=item $coin = coin_from_name $name
584 619
585=cut 620=cut
… …
720 755
721 my $t1 = Time::HiRes::time; 756 my $t1 = Time::HiRes::time;
722 my $data = $process->(\@data); 757 my $data = $process->(\@data);
723 my $t2 = Time::HiRes::time; 758 my $t2 = Time::HiRes::time;
724 759
725 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 760 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
726 761
727 db_put cache => "$id/data", $data; 762 db_put cache => "$id/data", $data;
728 db_put cache => "$id/md5" , $md5; 763 db_put cache => "$id/md5" , $md5;
729 db_put cache => "$id/meta", $meta; 764 db_put cache => "$id/meta", $meta;
730 765
… …
740 775
741=cut 776=cut
742 777
743sub datalog($@) { 778sub datalog($@) {
744 my ($type, %kv) = @_; 779 my ($type, %kv) = @_;
745 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 780 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
746} 781}
747 782
748=back 783=back
749 784
750=cut 785=cut
… …
945 980
946 } elsif (exists $cb_id{$type}) { 981 } elsif (exists $cb_id{$type}) {
947 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 982 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
948 983
949 } elsif (ref $type) { 984 } elsif (ref $type) {
950 warn "attaching objects not supported, ignoring.\n"; 985 error "attaching objects not supported, ignoring.\n";
951 986
952 } else { 987 } else {
953 shift @arg; 988 shift @arg;
954 warn "attach argument '$type' not supported, ignoring.\n"; 989 error "attach argument '$type' not supported, ignoring.\n";
955 } 990 }
956 } 991 }
957} 992}
958 993
959sub _object_attach { 994sub _object_attach {
… …
969 _attach $registry, $klass, @attach; 1004 _attach $registry, $klass, @attach;
970 } 1005 }
971 1006
972 $obj->{$name} = \%arg; 1007 $obj->{$name} = \%arg;
973 } else { 1008 } else {
974 warn "object uses attachment '$name' which is not available, postponing.\n"; 1009 info "object uses attachment '$name' which is not available, postponing.\n";
975 } 1010 }
976 1011
977 $obj->{_attachment}{$name} = undef; 1012 $obj->{_attachment}{$name} = undef;
978} 1013}
979 1014
… …
1038 1073
1039 for (@$callbacks) { 1074 for (@$callbacks) {
1040 eval { &{$_->[1]} }; 1075 eval { &{$_->[1]} };
1041 1076
1042 if ($@) { 1077 if ($@) {
1043 warn "$@";
1044 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1078 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1045 override; 1079 override;
1046 } 1080 }
1047 1081
1048 return 1 if $override; 1082 return 1 if $override;
1049 } 1083 }
… …
1128 for (@$attach) { 1162 for (@$attach) {
1129 my ($klass, @attach) = @$_; 1163 my ($klass, @attach) = @$_;
1130 _attach $registry, $klass, @attach; 1164 _attach $registry, $klass, @attach;
1131 } 1165 }
1132 } else { 1166 } else {
1133 warn "object uses attachment '$name' that is not available, postponing.\n"; 1167 info "object uses attachment '$name' that is not available, postponing.\n";
1134 } 1168 }
1135 } 1169 }
1136} 1170}
1137 1171
1138cf::attachable->attach ( 1172cf::attachable->attach (
… …
1165 my ($filename, $rdata, $objs) = @_; 1199 my ($filename, $rdata, $objs) = @_;
1166 1200
1167 sync_job { 1201 sync_job {
1168 if (length $$rdata) { 1202 if (length $$rdata) {
1169 utf8::decode (my $decname = $filename); 1203 utf8::decode (my $decname = $filename);
1170 warn sprintf "saving %s (%d,%d)\n", 1204 trace sprintf "saving %s (%d,%d)\n",
1171 $decname, length $$rdata, scalar @$objs; 1205 $decname, length $$rdata, scalar @$objs
1206 if $VERBOSE_IO;
1172 1207
1173 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1208 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1174 aio_chmod $fh, SAVE_MODE; 1209 aio_chmod $fh, SAVE_MODE;
1175 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1210 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1176 if ($cf::USE_FSYNC) { 1211 if ($cf::USE_FSYNC) {
… …
1198 aio_rename "$filename~", $filename; 1233 aio_rename "$filename~", $filename;
1199 1234
1200 $filename =~ s%/[^/]+$%%; 1235 $filename =~ s%/[^/]+$%%;
1201 aio_pathsync $filename if $cf::USE_FSYNC; 1236 aio_pathsync $filename if $cf::USE_FSYNC;
1202 } else { 1237 } else {
1203 warn "unable to save objects: $filename~: $!\n"; 1238 error "unable to save objects: $filename~: $!\n";
1204 } 1239 }
1205 } else { 1240 } else {
1206 aio_unlink $filename; 1241 aio_unlink $filename;
1207 aio_unlink "$filename.pst"; 1242 aio_unlink "$filename.pst";
1208 } 1243 }
… …
1232 my $st = eval { Coro::Storable::thaw $av }; 1267 my $st = eval { Coro::Storable::thaw $av };
1233 $av = $st->{objs}; 1268 $av = $st->{objs};
1234 } 1269 }
1235 1270
1236 utf8::decode (my $decname = $filename); 1271 utf8::decode (my $decname = $filename);
1237 warn sprintf "loading %s (%d,%d)\n", 1272 trace sprintf "loading %s (%d,%d)\n",
1238 $decname, length $data, scalar @{$av || []}; 1273 $decname, length $data, scalar @{$av || []}
1274 if $VERBOSE_IO;
1239 1275
1240 ($data, $av) 1276 ($data, $av)
1241} 1277}
1242 1278
1243=head2 COMMAND CALLBACKS 1279=head2 COMMAND CALLBACKS
… …
1302} 1338}
1303 1339
1304use File::Glob (); 1340use File::Glob ();
1305 1341
1306cf::player->attach ( 1342cf::player->attach (
1307 on_command => sub { 1343 on_unknown_command => sub {
1308 my ($pl, $name, $params) = @_; 1344 my ($pl, $name, $params) = @_;
1309 1345
1310 my $cb = $COMMAND{$name} 1346 my $cb = $COMMAND{$name}
1311 or return; 1347 or return;
1312 1348
… …
1335 1371
1336 $pl->ext_reply ($reply, @reply) 1372 $pl->ext_reply ($reply, @reply)
1337 if $reply; 1373 if $reply;
1338 1374
1339 } else { 1375 } else {
1340 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1376 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1341 } 1377 }
1342 1378
1343 cf::override; 1379 cf::override;
1344 }, 1380 },
1345); 1381);
… …
1356 1392
1357 $grp 1393 $grp
1358} 1394}
1359 1395
1360sub load_extensions { 1396sub load_extensions {
1397 info "loading extensions...";
1398
1361 cf::sync_job { 1399 cf::sync_job {
1362 my %todo; 1400 my %todo;
1363 1401
1364 for my $path (<$LIBDIR/*.ext>) { 1402 for my $path (<$LIBDIR/*.ext>) {
1365 next unless -r $path; 1403 next unless -r $path;
… …
1391 . "\n};\n1"; 1429 . "\n};\n1";
1392 1430
1393 $todo{$base} = \%ext; 1431 $todo{$base} = \%ext;
1394 } 1432 }
1395 1433
1434 my $pass = 0;
1396 my %done; 1435 my %done;
1397 while (%todo) { 1436 while (%todo) {
1398 my $progress; 1437 my $progress;
1399 1438
1439 ++$pass;
1440
1441 ext:
1400 while (my ($k, $v) = each %todo) { 1442 while (my ($k, $v) = each %todo) {
1401 for (split /,\s*/, $v->{meta}{depends}) { 1443 for (split /,\s*/, $v->{meta}{depends}) {
1402 goto skip 1444 next ext
1403 unless exists $done{$_}; 1445 unless exists $done{$_};
1404 } 1446 }
1405 1447
1406 warn "... loading '$k' into '$v->{pkg}'\n"; 1448 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1407 1449
1408 unless (eval $v->{source}) { 1450 my $active = eval $v->{source};
1451
1452 if (length $@) {
1409 my $msg = $@ ? "$v->{path}: $@\n" 1453 error "$v->{path}: $@\n";
1410 : "$v->{base}: extension inactive.\n";
1411 1454
1412 if (exists $v->{meta}{mandatory}) {
1413 warn $msg;
1414 cf::cleanup "mandatory extension failed to load, exiting."; 1455 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1415 } 1456 if exists $v->{meta}{mandatory};
1416 1457
1417 warn $msg; 1458 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1459 delete $todo{$k};
1460 } else {
1461 $done{$k} = delete $todo{$k};
1462 push @EXTS, $v->{pkg};
1463 $progress = 1;
1464
1465 info "$v->{base}: extension inactive.\n"
1466 unless $active;
1418 } 1467 }
1419
1420 $done{$k} = delete $todo{$k};
1421 push @EXTS, $v->{pkg};
1422 $progress = 1;
1423 } 1468 }
1424 1469
1425 skip: 1470 unless ($progress) {
1426 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1471 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1427 unless $progress; 1472
1473 while (my ($k, $v) = each %todo) {
1474 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1475 if exists $v->{meta}{mandatory};
1476 }
1477 }
1428 } 1478 }
1429 }; 1479 };
1430} 1480}
1431 1481
1432############################################################################# 1482#############################################################################
… …
1516 $cf::PLAYER{$login} = $pl 1566 $cf::PLAYER{$login} = $pl
1517 } 1567 }
1518 } 1568 }
1519} 1569}
1520 1570
1571cf::player->attach (
1572 on_load => sub {
1573 my ($pl, $path) = @_;
1574
1575 # restore slots saved in save, below
1576 my $slots = delete $pl->{_slots};
1577
1578 $pl->ob->current_weapon ($slots->[0]);
1579 $pl->combat_ob ($slots->[1]);
1580 $pl->ranged_ob ($slots->[2]);
1581 },
1582);
1583
1521sub save($) { 1584sub save($) {
1522 my ($pl) = @_; 1585 my ($pl) = @_;
1523 1586
1524 return if $pl->{deny_save}; 1587 return if $pl->{deny_save};
1525 1588
… …
1530 1593
1531 aio_mkdir playerdir $pl, 0770; 1594 aio_mkdir playerdir $pl, 0770;
1532 $pl->{last_save} = $cf::RUNTIME; 1595 $pl->{last_save} = $cf::RUNTIME;
1533 1596
1534 cf::get_slot 0.01; 1597 cf::get_slot 0.01;
1598
1599 # save slots, to be restored later
1600 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1535 1601
1536 $pl->save_pl ($path); 1602 $pl->save_pl ($path);
1537 cf::cede_to_tick; 1603 cf::cede_to_tick;
1538} 1604}
1539 1605
… …
1576 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1642 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1577 1643
1578 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1644 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1579 $pl->deactivate; 1645 $pl->deactivate;
1580 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1646 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1581 $pl->ob->check_score;
1582 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1647 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1583 $pl->ns->destroy if $pl->ns; 1648 $pl->ns->destroy if $pl->ns;
1584 1649
1585 my $path = playerdir $pl; 1650 my $path = playerdir $pl;
1586 my $temp = "$path~$cf::RUNTIME~deleting~"; 1651 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1641 \@logins 1706 \@logins
1642} 1707}
1643 1708
1644=item $player->maps 1709=item $player->maps
1645 1710
1711=item cf::player::maps $login
1712
1646Returns an arrayref of map paths that are private for this 1713Returns an arrayref of map paths that are private for this
1647player. May block. 1714player. May block.
1648 1715
1649=cut 1716=cut
1650 1717
… …
1712=cut 1779=cut
1713 1780
1714sub find_by_path($) { 1781sub find_by_path($) {
1715 my ($path) = @_; 1782 my ($path) = @_;
1716 1783
1784 $path =~ s/^~[^\/]*//; # skip ~login
1785
1717 my ($match, $specificity); 1786 my ($match, $specificity);
1718 1787
1719 for my $region (list) { 1788 for my $region (list) {
1720 if ($region->{match} && $path =~ $region->{match}) { 1789 if ($region->{match} && $path =~ $region->{match}) {
1721 ($match, $specificity) = ($region, $region->specificity) 1790 ($match, $specificity) = ($region, $region->specificity)
… …
1752 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1821 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1753 1822
1754 # mit "rum" bekleckern, nicht 1823 # mit "rum" bekleckern, nicht
1755 $self->_create_random_map ( 1824 $self->_create_random_map (
1756 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1825 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1757 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1826 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1758 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1827 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1759 $rmp->{exit_on_final_map}, 1828 $rmp->{exit_on_final_map},
1760 $rmp->{xsize}, $rmp->{ysize}, 1829 $rmp->{xsize}, $rmp->{ysize},
1761 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1830 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1762 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1831 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1784 1853
1785 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1854 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1786} 1855}
1787 1856
1788# also paths starting with '/' 1857# also paths starting with '/'
1789$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1858$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1790 1859
1791sub thawer_merge { 1860sub thawer_merge {
1792 my ($self, $merge) = @_; 1861 my ($self, $merge) = @_;
1793 1862
1794 # we have to keep some variables in memory intact 1863 # we have to keep some variables in memory intact
… …
2008 2077
2009 $cf::MAP{$path} = $map 2078 $cf::MAP{$path} = $map
2010 } 2079 }
2011} 2080}
2012 2081
2013sub pre_load { } 2082sub pre_load { }
2014sub post_load { } 2083#sub post_load { } # XS
2015 2084
2016sub load { 2085sub load {
2017 my ($self) = @_; 2086 my ($self) = @_;
2018 2087
2019 local $self->{deny_reset} = 1; # loading can take a long time 2088 local $self->{deny_reset} = 1; # loading can take a long time
… …
2076 } 2145 }
2077 2146
2078 $self->post_load; 2147 $self->post_load;
2079} 2148}
2080 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
2081sub customise_for { 2153sub customise_for {
2082 my ($self, $ob) = @_; 2154 my ($self, $ob) = @_;
2083 2155
2084 return find "~" . $ob->name . "/" . $self->{path} 2156 return find "~" . $ob->name . "/" . $self->{path}
2085 if $self->per_player; 2157 if $self->per_player;
… …
2101 or next; 2173 or next;
2102 $neigh = find $neigh, $map 2174 $neigh = find $neigh, $map
2103 or next; 2175 or next;
2104 $neigh->load; 2176 $neigh->load;
2105 2177
2178 # now find the diagonal neighbours
2106 push @neigh, 2179 push @neigh,
2107 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2180 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2108 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2181 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2109 } 2182 }
2110 2183
… …
2162 $MAP_PREFETCHER->prio (6); 2235 $MAP_PREFETCHER->prio (6);
2163 2236
2164 () 2237 ()
2165} 2238}
2166 2239
2240# common code, used by both ->save and ->swapout
2167sub save { 2241sub _save {
2168 my ($self) = @_; 2242 my ($self) = @_;
2169
2170 my $lock = cf::lock_acquire "map_data:$self->{path}";
2171 2243
2172 $self->{last_save} = $cf::RUNTIME; 2244 $self->{last_save} = $cf::RUNTIME;
2173 2245
2174 return unless $self->dirty; 2246 return unless $self->dirty;
2175 2247
… …
2195 } else { 2267 } else {
2196 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2268 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2197 } 2269 }
2198} 2270}
2199 2271
2272sub save {
2273 my ($self) = @_;
2274
2275 my $lock = cf::lock_acquire "map_data:$self->{path}";
2276
2277 $self->_save;
2278}
2279
2200sub swap_out { 2280sub swap_out {
2201 my ($self) = @_; 2281 my ($self) = @_;
2202 2282
2203 # save first because save cedes
2204 $self->save;
2205
2206 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2283 my $lock = cf::lock_acquire "map_data:$self->{path}";
2207 2284
2208 return if $self->players;
2209 return if $self->in_memory != cf::MAP_ACTIVE; 2285 return if $self->in_memory != cf::MAP_ACTIVE;
2210 return if $self->{deny_save}; 2286 return if $self->{deny_save};
2287 return if $self->players;
2211 2288
2289 # first deactivate the map and "unlink" it from the core
2290 $self->deactivate;
2291 $_->clear_links_to ($self) for values %cf::MAP;
2212 $self->in_memory (cf::MAP_SWAPPED); 2292 $self->in_memory (cf::MAP_SWAPPED);
2293
2294 # then atomically save
2295 $self->_save;
2296
2297 # then free the map
2298 $self->clear;
2299}
2300
2301sub reset_at {
2302 my ($self) = @_;
2303
2304 # TODO: safety, remove and allow resettable per-player maps
2305 return 1e99 if $self->{deny_reset};
2306
2307 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2308 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2309
2310 $time + $to
2311}
2312
2313sub should_reset {
2314 my ($self) = @_;
2315
2316 $self->reset_at <= $cf::RUNTIME
2317}
2318
2319sub reset {
2320 my ($self) = @_;
2321
2322 my $lock = cf::lock_acquire "map_data:$self->{path}";
2323
2324 return if $self->players;
2325
2326 cf::trace "resetting map ", $self->path, "\n";
2327
2328 $self->in_memory (cf::MAP_SWAPPED);
2329
2330 # need to save uniques path
2331 unless ($self->{deny_save}) {
2332 my $uniq = $self->uniq_path; utf8::encode $uniq;
2333
2334 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2335 if $uniq;
2336 }
2337
2338 delete $cf::MAP{$self->path};
2213 2339
2214 $self->deactivate; 2340 $self->deactivate;
2215 $_->clear_links_to ($self) for values %cf::MAP; 2341 $_->clear_links_to ($self) for values %cf::MAP;
2216 $self->clear; 2342 $self->clear;
2217}
2218
2219sub reset_at {
2220 my ($self) = @_;
2221
2222 # TODO: safety, remove and allow resettable per-player maps
2223 return 1e99 if $self->{deny_reset};
2224
2225 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2226 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2227
2228 $time + $to
2229}
2230
2231sub should_reset {
2232 my ($self) = @_;
2233
2234 $self->reset_at <= $cf::RUNTIME
2235}
2236
2237sub reset {
2238 my ($self) = @_;
2239
2240 my $lock = cf::lock_acquire "map_data:$self->{path}";
2241
2242 return if $self->players;
2243
2244 warn "resetting map ", $self->path, "\n";
2245
2246 $self->in_memory (cf::MAP_SWAPPED);
2247
2248 # need to save uniques path
2249 unless ($self->{deny_save}) {
2250 my $uniq = $self->uniq_path; utf8::encode $uniq;
2251
2252 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2253 if $uniq;
2254 }
2255
2256 delete $cf::MAP{$self->path};
2257
2258 $self->deactivate;
2259 $_->clear_links_to ($self) for values %cf::MAP;
2260 $self->clear;
2261 2343
2262 $self->unlink_save; 2344 $self->unlink_save;
2263 $self->destroy; 2345 $self->destroy;
2264} 2346}
2265 2347
… …
2273 2355
2274 delete $cf::MAP{$self->path}; 2356 delete $cf::MAP{$self->path};
2275 2357
2276 $self->unlink_save; 2358 $self->unlink_save;
2277 2359
2278 bless $self, "cf::map"; 2360 bless $self, "cf::map::wrap";
2279 delete $self->{deny_reset}; 2361 delete $self->{deny_reset};
2280 $self->{deny_save} = 1; 2362 $self->{deny_save} = 1;
2281 $self->reset_timeout (1); 2363 $self->reset_timeout (1);
2282 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2364 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2283 2365
… …
2340 : normalise $_ 2422 : normalise $_
2341 } @{ aio_readdir $UNIQUEDIR or [] } 2423 } @{ aio_readdir $UNIQUEDIR or [] }
2342 ] 2424 ]
2343} 2425}
2344 2426
2427=item cf::map::static_maps
2428
2429Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2430file in the shared directory excluding F</styles> and F</editor>). May
2431block.
2432
2433=cut
2434
2435sub static_maps() {
2436 my @dirs = "";
2437 my @maps;
2438
2439 while (@dirs) {
2440 my $dir = shift @dirs;
2441
2442 next if $dir eq "/styles" || $dir eq "/editor";
2443
2444 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2445 or return;
2446
2447 for (@$files) {
2448 s/\.map$// or next;
2449 utf8::decode $_;
2450 push @maps, "$dir/$_";
2451 }
2452
2453 push @dirs, map "$dir/$_", @$dirs;
2454 }
2455
2456 \@maps
2457}
2458
2345=back 2459=back
2346 2460
2347=head3 cf::object 2461=head3 cf::object
2348 2462
2349=cut 2463=cut
… …
2481 2595
2482Freezes the player and moves him/her to a special map (C<{link}>). 2596Freezes the player and moves him/her to a special map (C<{link}>).
2483 2597
2484The player should be reasonably safe there for short amounts of time (e.g. 2598The player should be reasonably safe there for short amounts of time (e.g.
2485for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2599for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2486though, as the palyer cannot control the character while it is on the link 2600though, as the player cannot control the character while it is on the link
2487map. 2601map.
2488 2602
2489Will never block. 2603Will never block.
2490 2604
2491=item $player_object->leave_link ($map, $x, $y) 2605=item $player_object->leave_link ($map, $x, $y)
… …
2512sub cf::object::player::enter_link { 2626sub cf::object::player::enter_link {
2513 my ($self) = @_; 2627 my ($self) = @_;
2514 2628
2515 $self->deactivate_recursive; 2629 $self->deactivate_recursive;
2516 2630
2631 ++$self->{_link_recursion};
2632
2517 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2633 return if UNIVERSAL::isa $self->map, "ext::map_link";
2518 2634
2519 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2635 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2520 if $self->map && $self->map->{path} ne "{link}"; 2636 if $self->map && $self->map->{path} ne "{link}";
2521 2637
2522 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2638 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2523} 2639}
2524 2640
2525sub cf::object::player::leave_link { 2641sub cf::object::player::leave_link {
2526 my ($self, $map, $x, $y) = @_; 2642 my ($self, $map, $x, $y) = @_;
2527 2643
… …
2544 ($x, $y) = (-1, -1) 2660 ($x, $y) = (-1, -1)
2545 unless (defined $x) && (defined $y); 2661 unless (defined $x) && (defined $y);
2546 2662
2547 # use -1 or undef as default coordinates, not 0, 0 2663 # use -1 or undef as default coordinates, not 0, 0
2548 ($x, $y) = ($map->enter_x, $map->enter_y) 2664 ($x, $y) = ($map->enter_x, $map->enter_y)
2549 if $x <=0 && $y <= 0; 2665 if $x <= 0 && $y <= 0;
2550 2666
2551 $map->load; 2667 $map->load;
2552 $map->load_neighbours; 2668 $map->load_neighbours;
2553 2669
2554 return unless $self->contr->active; 2670 return unless $self->contr->active;
2555 2671
2556 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2672 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2557 $self->enter_map ($map, $x, $y); 2673 if ($self->enter_map ($map, $x, $y)) {
2558 2674 # entering was successful
2675 delete $self->{_link_recursion};
2559 # only activate afterwards, to support waiting in hooks 2676 # only activate afterwards, to support waiting in hooks
2560 $self->activate_recursive; 2677 $self->activate_recursive;
2561} 2678 }
2562 2679
2680}
2681
2563=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2682=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2564 2683
2565Moves the player to the given map-path and coordinates by first freezing 2684Moves the player to the given map-path and coordinates by first freezing
2566her, loading and preparing them map, calling the provided $check callback 2685her, loading and preparing them map, calling the provided $check callback
2567that has to return the map if sucecssful, and then unfreezes the player on 2686that has to return the map if sucecssful, and then unfreezes the player on
2568the new (success) or old (failed) map position. In either case, $done will 2687the new (success) or old (failed) map position. In either case, $done will
… …
2575 2694
2576our $GOTOGEN; 2695our $GOTOGEN;
2577 2696
2578sub cf::object::player::goto { 2697sub cf::object::player::goto {
2579 my ($self, $path, $x, $y, $check, $done) = @_; 2698 my ($self, $path, $x, $y, $check, $done) = @_;
2699
2700 if ($self->{_link_recursion} >= $MAX_LINKS) {
2701 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2702 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2703 ($path, $x, $y) = @$EMERGENCY_POSITION;
2704 }
2580 2705
2581 # do generation counting so two concurrent goto's will be executed in-order 2706 # do generation counting so two concurrent goto's will be executed in-order
2582 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2707 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2583 2708
2584 $self->enter_link; 2709 $self->enter_link;
… …
2608 my $map = eval { 2733 my $map = eval {
2609 my $map = defined $path ? cf::map::find $path : undef; 2734 my $map = defined $path ? cf::map::find $path : undef;
2610 2735
2611 if ($map) { 2736 if ($map) {
2612 $map = $map->customise_for ($self); 2737 $map = $map->customise_for ($self);
2613 $map = $check->($map) if $check && $map; 2738 $map = $check->($map, $x, $y, $self) if $check && $map;
2614 } else { 2739 } else {
2615 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2740 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2616 } 2741 }
2617 2742
2618 $map 2743 $map
… …
2626 if ($gen == $self->{_goto_generation}) { 2751 if ($gen == $self->{_goto_generation}) {
2627 delete $self->{_goto_generation}; 2752 delete $self->{_goto_generation};
2628 $self->leave_link ($map, $x, $y); 2753 $self->leave_link ($map, $x, $y);
2629 } 2754 }
2630 2755
2631 $done->() if $done; 2756 $done->($self) if $done;
2632 })->prio (1); 2757 })->prio (1);
2633} 2758}
2634 2759
2635=item $player_object->enter_exit ($exit_object) 2760=item $player_object->enter_exit ($exit_object)
2636 2761
… …
2729 $self->message ("Something went wrong deep within the deliantra server. " 2854 $self->message ("Something went wrong deep within the deliantra server. "
2730 . "I'll try to bring you back to the map you were before. " 2855 . "I'll try to bring you back to the map you were before. "
2731 . "Please report this to the dungeon master!", 2856 . "Please report this to the dungeon master!",
2732 cf::NDI_UNIQUE | cf::NDI_RED); 2857 cf::NDI_UNIQUE | cf::NDI_RED);
2733 2858
2734 warn "ERROR in enter_exit: $@"; 2859 error "ERROR in enter_exit: $@";
2735 $self->leave_link; 2860 $self->leave_link;
2736 } 2861 }
2737 })->prio (1); 2862 })->prio (1);
2738} 2863}
2739 2864
… …
2751sub cf::client::send_drawinfo { 2876sub cf::client::send_drawinfo {
2752 my ($self, $text, $flags) = @_; 2877 my ($self, $text, $flags) = @_;
2753 2878
2754 utf8::encode $text; 2879 utf8::encode $text;
2755 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2880 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2881}
2882
2883=item $client->send_big_packet ($pkt)
2884
2885Like C<send_packet>, but tries to compress large packets, and fragments
2886them as required.
2887
2888=cut
2889
2890our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2891
2892sub cf::client::send_big_packet {
2893 my ($self, $pkt) = @_;
2894
2895 # try lzf for large packets
2896 $pkt = "lzf " . Compress::LZF::compress $pkt
2897 if 1024 <= length $pkt and $self->{can_lzf};
2898
2899 # split very large packets
2900 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2901 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2902 $pkt = "frag";
2903 }
2904
2905 $self->send_packet ($pkt);
2756} 2906}
2757 2907
2758=item $client->send_msg ($channel, $msg, $color, [extra...]) 2908=item $client->send_msg ($channel, $msg, $color, [extra...])
2759 2909
2760Send a drawinfo or msg packet to the client, formatting the msg for the 2910Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2764 2914
2765=cut 2915=cut
2766 2916
2767# non-persistent channels (usually the info channel) 2917# non-persistent channels (usually the info channel)
2768our %CHANNEL = ( 2918our %CHANNEL = (
2919 "c/motd" => {
2920 id => "infobox",
2921 title => "MOTD",
2922 reply => undef,
2923 tooltip => "The message of the day",
2924 },
2769 "c/identify" => { 2925 "c/identify" => {
2770 id => "infobox", 2926 id => "infobox",
2771 title => "Identify", 2927 title => "Identify",
2772 reply => undef, 2928 reply => undef,
2773 tooltip => "Items recently identified", 2929 tooltip => "Items recently identified",
… …
2775 "c/examine" => { 2931 "c/examine" => {
2776 id => "infobox", 2932 id => "infobox",
2777 title => "Examine", 2933 title => "Examine",
2778 reply => undef, 2934 reply => undef,
2779 tooltip => "Signs and other items you examined", 2935 tooltip => "Signs and other items you examined",
2936 },
2937 "c/shopinfo" => {
2938 id => "infobox",
2939 title => "Shop Info",
2940 reply => undef,
2941 tooltip => "What your bargaining skill tells you about the shop",
2780 }, 2942 },
2781 "c/book" => { 2943 "c/book" => {
2782 id => "infobox", 2944 id => "infobox",
2783 title => "Book", 2945 title => "Book",
2784 reply => undef, 2946 reply => undef,
… …
2900 my $pkt = "msg " 3062 my $pkt = "msg "
2901 . $self->{json_coder}->encode ( 3063 . $self->{json_coder}->encode (
2902 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3064 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2903 ); 3065 );
2904 3066
2905 # try lzf for large packets
2906 $pkt = "lzf " . Compress::LZF::compress $pkt
2907 if 1024 <= length $pkt and $self->{can_lzf};
2908
2909 # split very large packets
2910 if (8192 < length $pkt and $self->{can_lzf}) {
2911 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2912 $pkt = "frag";
2913 }
2914
2915 $self->send_packet ($pkt); 3067 $self->send_big_packet ($pkt);
2916} 3068}
2917 3069
2918=item $client->ext_msg ($type, @msg) 3070=item $client->ext_msg ($type, @msg)
2919 3071
2920Sends an ext event to the client. 3072Sends an ext event to the client.
… …
2923 3075
2924sub cf::client::ext_msg($$@) { 3076sub cf::client::ext_msg($$@) {
2925 my ($self, $type, @msg) = @_; 3077 my ($self, $type, @msg) = @_;
2926 3078
2927 if ($self->extcmd == 2) { 3079 if ($self->extcmd == 2) {
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3080 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2929 } elsif ($self->extcmd == 1) { # TODO: remove 3081 } elsif ($self->extcmd == 1) { # TODO: remove
2930 push @msg, msgtype => "event_$type"; 3082 push @msg, msgtype => "event_$type";
2931 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3083 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2932 } 3084 }
2933} 3085}
2934 3086
2935=item $client->ext_reply ($msgid, @msg) 3087=item $client->ext_reply ($msgid, @msg)
2936 3088
… …
2940 3092
2941sub cf::client::ext_reply($$@) { 3093sub cf::client::ext_reply($$@) {
2942 my ($self, $id, @msg) = @_; 3094 my ($self, $id, @msg) = @_;
2943 3095
2944 if ($self->extcmd == 2) { 3096 if ($self->extcmd == 2) {
2945 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3097 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2946 } elsif ($self->extcmd == 1) { 3098 } elsif ($self->extcmd == 1) {
2947 #TODO: version 1, remove 3099 #TODO: version 1, remove
2948 unshift @msg, msgtype => "reply", msgid => $id; 3100 unshift @msg, msgtype => "reply", msgid => $id;
2949 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3101 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2950 } 3102 }
2951} 3103}
2952 3104
2953=item $success = $client->query ($flags, "text", \&cb) 3105=item $success = $client->query ($flags, "text", \&cb)
2954 3106
… …
3025 3177
3026 $ns->ext_reply ($reply, @reply) 3178 $ns->ext_reply ($reply, @reply)
3027 if $reply; 3179 if $reply;
3028 3180
3029 } else { 3181 } else {
3030 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3182 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3031 } 3183 }
3032 3184
3033 cf::override; 3185 cf::override;
3034 }, 3186 },
3035); 3187);
… …
3055 3207
3056 $coro 3208 $coro
3057} 3209}
3058 3210
3059cf::client->attach ( 3211cf::client->attach (
3060 on_destroy => sub { 3212 on_client_destroy => sub {
3061 my ($ns) = @_; 3213 my ($ns) = @_;
3062 3214
3063 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3215 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3064 }, 3216 },
3065); 3217);
… …
3081our $safe_hole = new Safe::Hole; 3233our $safe_hole = new Safe::Hole;
3082 3234
3083$SIG{FPE} = 'IGNORE'; 3235$SIG{FPE} = 'IGNORE';
3084 3236
3085$safe->permit_only (Opcode::opset qw( 3237$safe->permit_only (Opcode::opset qw(
3086 :base_core :base_mem :base_orig :base_math 3238 :base_core :base_mem :base_orig :base_math :base_loop
3087 grepstart grepwhile mapstart mapwhile 3239 grepstart grepwhile mapstart mapwhile
3088 sort time 3240 sort time
3089)); 3241));
3090 3242
3091# here we export the classes and methods available to script code 3243# here we export the classes and methods available to script code
… …
3143 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3295 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3144 $qcode =~ s/\n/\\n/g; 3296 $qcode =~ s/\n/\\n/g;
3145 3297
3146 %vars = (_dummy => 0) unless %vars; 3298 %vars = (_dummy => 0) unless %vars;
3147 3299
3300 my @res;
3148 local $_; 3301 local $_;
3149 local @safe::cf::_safe_eval_args = values %vars;
3150 3302
3151 my $eval = 3303 my $eval =
3152 "do {\n" 3304 "do {\n"
3153 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3305 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3154 . "#line 0 \"{$qcode}\"\n" 3306 . "#line 0 \"{$qcode}\"\n"
3155 . $code 3307 . $code
3156 . "\n}" 3308 . "\n}"
3157 ; 3309 ;
3158 3310
3311 if ($CFG{safe_eval}) {
3159 sub_generation_inc; 3312 sub_generation_inc;
3313 local @safe::cf::_safe_eval_args = values %vars;
3160 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3314 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3161 sub_generation_inc; 3315 sub_generation_inc;
3316 } else {
3317 local @cf::_safe_eval_args = values %vars;
3318 @res = wantarray ? eval eval : scalar eval $eval;
3319 }
3162 3320
3163 if ($@) { 3321 if ($@) {
3164 warn "$@"; 3322 warn "$@",
3165 warn "while executing safe code '$code'\n"; 3323 "while executing safe code '$code'\n",
3166 warn "with arguments " . (join " ", %vars) . "\n"; 3324 "with arguments " . (join " ", %vars) . "\n";
3167 } 3325 }
3168 3326
3169 wantarray ? @res : $res[0] 3327 wantarray ? @res : $res[0]
3170} 3328}
3171 3329
… …
3185=cut 3343=cut
3186 3344
3187sub register_script_function { 3345sub register_script_function {
3188 my ($fun, $cb) = @_; 3346 my ($fun, $cb) = @_;
3189 3347
3190 no strict 'refs'; 3348 $fun = "safe::$fun" if $CFG{safe_eval};
3191 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3349 *$fun = $safe_hole->wrap ($cb);
3192} 3350}
3193 3351
3194=back 3352=back
3195 3353
3196=cut 3354=cut
… …
3205 # for this (global event?) 3363 # for this (global event?)
3206 %ext::player_env::MUSIC_FACE_CACHE = (); 3364 %ext::player_env::MUSIC_FACE_CACHE = ();
3207 3365
3208 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3366 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3209 3367
3210 warn "loading facedata from $path\n"; 3368 trace "loading facedata from $path\n";
3211 3369
3212 my $facedata; 3370 my $facedata;
3213 0 < aio_load $path, $facedata 3371 0 < aio_load $path, $facedata
3214 or die "$path: $!"; 3372 or die "$path: $!";
3215 3373
… …
3217 3375
3218 $facedata->{version} == 2 3376 $facedata->{version} == 2
3219 or cf::cleanup "$path: version mismatch, cannot proceed."; 3377 or cf::cleanup "$path: version mismatch, cannot proceed.";
3220 3378
3221 # patch in the exptable 3379 # patch in the exptable
3380 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3222 $facedata->{resource}{"res/exp_table"} = { 3381 $facedata->{resource}{"res/exp_table"} = {
3223 type => FT_RSRC, 3382 type => FT_RSRC,
3224 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3383 data => $exp_table,
3384 hash => (Digest::MD5::md5 $exp_table),
3225 }; 3385 };
3226 cf::cede_to_tick; 3386 cf::cede_to_tick;
3227 3387
3228 { 3388 {
3229 my $faces = $facedata->{faceinfo}; 3389 my $faces = $facedata->{faceinfo};
… …
3231 while (my ($face, $info) = each %$faces) { 3391 while (my ($face, $info) = each %$faces) {
3232 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3392 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3233 3393
3234 cf::face::set_visibility $idx, $info->{visibility}; 3394 cf::face::set_visibility $idx, $info->{visibility};
3235 cf::face::set_magicmap $idx, $info->{magicmap}; 3395 cf::face::set_magicmap $idx, $info->{magicmap};
3236 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3396 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3237 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3397 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3238 3398
3239 cf::cede_to_tick; 3399 cf::cede_to_tick;
3240 } 3400 }
3241 3401
3242 while (my ($face, $info) = each %$faces) { 3402 while (my ($face, $info) = each %$faces) {
… …
3247 3407
3248 if (my $smooth = cf::face::find $info->{smooth}) { 3408 if (my $smooth = cf::face::find $info->{smooth}) {
3249 cf::face::set_smooth $idx, $smooth; 3409 cf::face::set_smooth $idx, $smooth;
3250 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3410 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3251 } else { 3411 } else {
3252 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3412 error "smooth face '$info->{smooth}' not found for face '$face'";
3253 } 3413 }
3254 3414
3255 cf::cede_to_tick; 3415 cf::cede_to_tick;
3256 } 3416 }
3257 } 3417 }
… …
3266 3426
3267 cf::anim::invalidate_all; # d'oh 3427 cf::anim::invalidate_all; # d'oh
3268 } 3428 }
3269 3429
3270 { 3430 {
3271 # TODO: for gcfclient pleasure, we should give resources
3272 # that gcfclient doesn't grok a >10000 face index.
3273 my $res = $facedata->{resource}; 3431 my $res = $facedata->{resource};
3274 3432
3275 while (my ($name, $info) = each %$res) { 3433 while (my ($name, $info) = each %$res) {
3276 if (defined $info->{type}) { 3434 if (defined $info->{type}) {
3277 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3435 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3278 my $data;
3279 3436
3280 if ($info->{type} & 1) { 3437 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3281 # prepend meta info
3282
3283 my $meta = $enc->encode ({
3284 name => $name,
3285 %{ $info->{meta} || {} },
3286 });
3287
3288 $data = pack "(w/a*)*", $meta, $info->{data};
3289 } else {
3290 $data = $info->{data};
3291 }
3292
3293 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3294 cf::face::set_type $idx, $info->{type}; 3438 cf::face::set_type $idx, $info->{type};
3295 } else { 3439 } else {
3296 $RESOURCE{$name} = $info; 3440 $RESOURCE{$name} = $info; # unused
3297 } 3441 }
3298 3442
3299 cf::cede_to_tick; 3443 cf::cede_to_tick;
3300 } 3444 }
3301 } 3445 }
3302 3446
3303 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3447 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3304 3448
3305 1 3449 1
3306} 3450}
3307
3308cf::global->attach (on_resource_update => sub {
3309 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3310 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3311
3312 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3313 my $sound = $soundconf->{compat}[$_]
3314 or next;
3315
3316 my $face = cf::face::find "sound/$sound->[1]";
3317 cf::sound::set $sound->[0] => $face;
3318 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3319 }
3320
3321 while (my ($k, $v) = each %{$soundconf->{event}}) {
3322 my $face = cf::face::find "sound/$v";
3323 cf::sound::set $k => $face;
3324 }
3325 }
3326});
3327 3451
3328register_exticmd fx_want => sub { 3452register_exticmd fx_want => sub {
3329 my ($ns, $want) = @_; 3453 my ($ns, $want) = @_;
3330 3454
3331 while (my ($k, $v) = each %$want) { 3455 while (my ($k, $v) = each %$want) {
… …
3370sub reload_treasures { 3494sub reload_treasures {
3371 load_resource_file "$DATADIR/treasures" 3495 load_resource_file "$DATADIR/treasures"
3372 or die "unable to load treasurelists\n"; 3496 or die "unable to load treasurelists\n";
3373} 3497}
3374 3498
3499sub reload_sound {
3500 trace "loading sound config from $DATADIR/sound\n";
3501
3502 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3503 or die "$DATADIR/sound $!";
3504
3505 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3506
3507 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3508 my $sound = $soundconf->{compat}[$_]
3509 or next;
3510
3511 my $face = cf::face::find "sound/$sound->[1]";
3512 cf::sound::set $sound->[0] => $face;
3513 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3514 }
3515
3516 while (my ($k, $v) = each %{$soundconf->{event}}) {
3517 my $face = cf::face::find "sound/$v";
3518 cf::sound::set $k => $face;
3519 }
3520}
3521
3375sub reload_resources { 3522sub reload_resources {
3376 warn "reloading resource files...\n"; 3523 trace "reloading resource files...\n";
3377 3524
3378 reload_facedata; 3525 reload_facedata;
3526 reload_sound;
3379 reload_archetypes; 3527 reload_archetypes;
3380 reload_regions; 3528 reload_regions;
3381 reload_treasures; 3529 reload_treasures;
3382 3530
3383 warn "finished reloading resource files\n"; 3531 trace "finished reloading resource files\n";
3384} 3532}
3385 3533
3386sub reload_config { 3534sub reload_config {
3535 trace "reloading config file...\n";
3536
3387 open my $fh, "<:utf8", "$CONFDIR/config" 3537 open my $fh, "<:utf8", "$CONFDIR/config"
3388 or return; 3538 or return;
3389 3539
3390 local $/; 3540 local $/;
3391 *CFG = YAML::Load <$fh>; 3541 *CFG = YAML::XS::Load scalar <$fh>;
3392 3542
3393 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3543 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3394 3544
3395 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3545 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3396 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3546 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3397 3547
3398 if (exists $CFG{mlockall}) { 3548 if (exists $CFG{mlockall}) {
… …
3400 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3550 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3401 and die "WARNING: m(un)lockall failed: $!\n"; 3551 and die "WARNING: m(un)lockall failed: $!\n";
3402 }; 3552 };
3403 warn $@ if $@; 3553 warn $@ if $@;
3404 } 3554 }
3555
3556 trace "finished reloading resource files\n";
3405} 3557}
3406 3558
3407sub pidfile() { 3559sub pidfile() {
3408 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3560 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3409 or die "$PIDFILE: $!"; 3561 or die "$PIDFILE: $!";
… …
3422 seek $fh, 0, 0; 3574 seek $fh, 0, 0;
3423 print $fh $$; 3575 print $fh $$;
3424} 3576}
3425 3577
3426sub main_loop { 3578sub main_loop {
3427 warn "EV::loop starting\n"; 3579 trace "EV::loop starting\n";
3428 if (1) { 3580 if (1) {
3429 EV::loop; 3581 EV::loop;
3430 } 3582 }
3431 warn "EV::loop returned\n"; 3583 trace "EV::loop returned\n";
3432 goto &main_loop unless $REALLY_UNLOOP; 3584 goto &main_loop unless $REALLY_UNLOOP;
3433} 3585}
3434 3586
3435sub main { 3587sub main {
3436 cf::init_globals; # initialise logging 3588 cf::init_globals; # initialise logging
3437 3589
3438 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3590 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3439 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3591 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3440 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3592 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3441 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3593 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3442
3443 cf::init_experience;
3444 cf::init_anim;
3445 cf::init_attackmess;
3446 cf::init_dynamic;
3447 3594
3448 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3595 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3449 3596
3450 # we must not ever block the main coroutine 3597 # we must not ever block the main coroutine
3451 local $Coro::idle = sub { 3598 local $Coro::idle = sub {
… …
3457 }; 3604 };
3458 3605
3459 evthread_start IO::AIO::poll_fileno; 3606 evthread_start IO::AIO::poll_fileno;
3460 3607
3461 cf::sync_job { 3608 cf::sync_job {
3609 cf::init_experience;
3610 cf::init_anim;
3611 cf::init_attackmess;
3612 cf::init_dynamic;
3613
3614 cf::load_settings;
3615 cf::load_materials;
3616
3462 reload_resources; 3617 reload_resources;
3463 reload_config; 3618 reload_config;
3464 db_init; 3619 db_init;
3465 3620
3466 cf::load_settings;
3467 cf::load_materials;
3468 cf::init_uuid; 3621 cf::init_uuid;
3469 cf::init_signals; 3622 cf::init_signals;
3470 cf::init_commands;
3471 cf::init_skills; 3623 cf::init_skills;
3472 3624
3473 cf::init_beforeplay; 3625 cf::init_beforeplay;
3474 3626
3475 atomic; 3627 atomic;
… …
3482 use POSIX (); 3634 use POSIX ();
3483 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3635 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3484 3636
3485 (pop @POST_INIT)->(0) while @POST_INIT; 3637 (pop @POST_INIT)->(0) while @POST_INIT;
3486 }; 3638 };
3639
3640 cf::object::thawer::errors_are_fatal 0;
3641 info "parse errors in files are no longer fatal from this point on.\n";
3487 3642
3488 main_loop; 3643 main_loop;
3489} 3644}
3490 3645
3491############################################################################# 3646#############################################################################
… …
3493 3648
3494# install some emergency cleanup handlers 3649# install some emergency cleanup handlers
3495BEGIN { 3650BEGIN {
3496 our %SIGWATCHER = (); 3651 our %SIGWATCHER = ();
3497 for my $signal (qw(INT HUP TERM)) { 3652 for my $signal (qw(INT HUP TERM)) {
3498 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3653 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3499 cf::cleanup "SIG$signal"; 3654 cf::cleanup "SIG$signal";
3500 }; 3655 };
3501 } 3656 }
3502} 3657}
3503 3658
3504sub write_runtime_sync { 3659sub write_runtime_sync {
3660 my $t0 = AE::time;
3661
3505 # first touch the runtime file to show we are still running: 3662 # first touch the runtime file to show we are still running:
3506 # the fsync below can take a very very long time. 3663 # the fsync below can take a very very long time.
3507 3664
3508 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3665 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3509 3666
3510 my $guard = cf::lock_acquire "write_runtime"; 3667 my $guard = cf::lock_acquire "write_runtime";
3511 3668
3512 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3669 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3513 or return; 3670 or return;
3514 3671
3515 my $value = $cf::RUNTIME + 90 + 10; 3672 my $value = $cf::RUNTIME + 90 + 10;
3516 # 10 is the runtime save interval, for a monotonic clock 3673 # 10 is the runtime save interval, for a monotonic clock
3517 # 60 allows for the watchdog to kill the server. 3674 # 60 allows for the watchdog to kill the server.
… …
3530 or return; 3687 or return;
3531 3688
3532 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3689 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3533 and return; 3690 and return;
3534 3691
3535 warn "runtime file written.\n"; 3692 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3536 3693
3537 1 3694 1
3538} 3695}
3539 3696
3540our $uuid_lock; 3697our $uuid_lock;
… …
3552 or return; 3709 or return;
3553 3710
3554 my $value = uuid_seq uuid_cur; 3711 my $value = uuid_seq uuid_cur;
3555 3712
3556 unless ($value) { 3713 unless ($value) {
3557 warn "cowardly refusing to write zero uuid value!\n"; 3714 info "cowardly refusing to write zero uuid value!\n";
3558 return; 3715 return;
3559 } 3716 }
3560 3717
3561 my $value = uuid_str $value + $uuid_skip; 3718 my $value = uuid_str $value + $uuid_skip;
3562 $uuid_skip = 0; 3719 $uuid_skip = 0;
… …
3572 or return; 3729 or return;
3573 3730
3574 aio_rename "$uuid~", $uuid 3731 aio_rename "$uuid~", $uuid
3575 and return; 3732 and return;
3576 3733
3577 warn "uuid file written ($value).\n"; 3734 trace "uuid file written ($value).\n";
3578 3735
3579 1 3736 1
3580 3737
3581} 3738}
3582 3739
… …
3588} 3745}
3589 3746
3590sub emergency_save() { 3747sub emergency_save() {
3591 my $freeze_guard = cf::freeze_mainloop; 3748 my $freeze_guard = cf::freeze_mainloop;
3592 3749
3593 warn "emergency_perl_save: enter\n"; 3750 info "emergency_perl_save: enter\n";
3594 3751
3595 cf::sync_job { 3752 cf::sync_job {
3596 # this is a trade-off: we want to be very quick here, so 3753 # this is a trade-off: we want to be very quick here, so
3597 # save all maps without fsync, and later call a global sync 3754 # save all maps without fsync, and later call a global sync
3598 # (which in turn might be very very slow) 3755 # (which in turn might be very very slow)
3599 local $USE_FSYNC = 0; 3756 local $USE_FSYNC = 0;
3600 3757
3601 # use a peculiar iteration method to avoid tripping on perl 3758 # use a peculiar iteration method to avoid tripping on perl
3602 # refcount bugs in for. also avoids problems with players 3759 # refcount bugs in for. also avoids problems with players
3603 # and maps saved/destroyed asynchronously. 3760 # and maps saved/destroyed asynchronously.
3604 warn "emergency_perl_save: begin player save\n"; 3761 info "emergency_perl_save: begin player save\n";
3605 for my $login (keys %cf::PLAYER) { 3762 for my $login (keys %cf::PLAYER) {
3606 my $pl = $cf::PLAYER{$login} or next; 3763 my $pl = $cf::PLAYER{$login} or next;
3607 $pl->valid or next; 3764 $pl->valid or next;
3608 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3765 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3609 $pl->save; 3766 $pl->save;
3610 } 3767 }
3611 warn "emergency_perl_save: end player save\n"; 3768 info "emergency_perl_save: end player save\n";
3612 3769
3613 warn "emergency_perl_save: begin map save\n"; 3770 info "emergency_perl_save: begin map save\n";
3614 for my $path (keys %cf::MAP) { 3771 for my $path (keys %cf::MAP) {
3615 my $map = $cf::MAP{$path} or next; 3772 my $map = $cf::MAP{$path} or next;
3616 $map->valid or next; 3773 $map->valid or next;
3617 $map->save; 3774 $map->save;
3618 } 3775 }
3619 warn "emergency_perl_save: end map save\n"; 3776 info "emergency_perl_save: end map save\n";
3620 3777
3621 warn "emergency_perl_save: begin database checkpoint\n"; 3778 info "emergency_perl_save: begin database checkpoint\n";
3622 BDB::db_env_txn_checkpoint $DB_ENV; 3779 BDB::db_env_txn_checkpoint $DB_ENV;
3623 warn "emergency_perl_save: end database checkpoint\n"; 3780 info "emergency_perl_save: end database checkpoint\n";
3624 3781
3625 warn "emergency_perl_save: begin write uuid\n"; 3782 info "emergency_perl_save: begin write uuid\n";
3626 write_uuid_sync 1; 3783 write_uuid_sync 1;
3627 warn "emergency_perl_save: end write uuid\n"; 3784 info "emergency_perl_save: end write uuid\n";
3628 }; 3785 };
3629 3786
3630 warn "emergency_perl_save: starting sync()\n"; 3787 info "emergency_perl_save: starting sync()\n";
3631 IO::AIO::aio_sync sub { 3788 IO::AIO::aio_sync sub {
3632 warn "emergency_perl_save: finished sync()\n"; 3789 info "emergency_perl_save: finished sync()\n";
3633 }; 3790 };
3634 3791
3635 warn "emergency_perl_save: leave\n"; 3792 info "emergency_perl_save: leave\n";
3636} 3793}
3637 3794
3638sub post_cleanup { 3795sub post_cleanup {
3639 my ($make_core) = @_; 3796 my ($make_core) = @_;
3640 3797
3641 warn Carp::longmess "post_cleanup backtrace" 3798 error Carp::longmess "post_cleanup backtrace"
3642 if $make_core; 3799 if $make_core;
3643 3800
3644 my $fh = pidfile; 3801 my $fh = pidfile;
3645 unlink $PIDFILE if <$fh> == $$; 3802 unlink $PIDFILE if <$fh> == $$;
3646} 3803}
… …
3666 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3823 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3667 for my $name (keys %$leaf_symtab) { 3824 for my $name (keys %$leaf_symtab) {
3668 _gv_clear *{"$pkg$name"}; 3825 _gv_clear *{"$pkg$name"};
3669# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3826# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3670 } 3827 }
3671 warn "cleared package $pkg\n";#d#
3672} 3828}
3673 3829
3674sub do_reload_perl() { 3830sub do_reload_perl() {
3675 # can/must only be called in main 3831 # can/must only be called in main
3676 if ($Coro::current != $Coro::main) { 3832 if (in_main) {
3677 warn "can only reload from main coroutine"; 3833 error "can only reload from main coroutine";
3678 return; 3834 return;
3679 } 3835 }
3680 3836
3681 return if $RELOAD++; 3837 return if $RELOAD++;
3682 3838
3683 my $t1 = EV::time; 3839 my $t1 = AE::time;
3684 3840
3685 while ($RELOAD) { 3841 while ($RELOAD) {
3686 warn "reloading..."; 3842 info "reloading...";
3687 3843
3688 warn "entering sync_job"; 3844 trace "entering sync_job";
3689 3845
3690 cf::sync_job { 3846 cf::sync_job {
3691 cf::write_runtime_sync; # external watchdog should not bark 3847 cf::write_runtime_sync; # external watchdog should not bark
3692 cf::emergency_save; 3848 cf::emergency_save;
3693 cf::write_runtime_sync; # external watchdog should not bark 3849 cf::write_runtime_sync; # external watchdog should not bark
3694 3850
3695 warn "syncing database to disk"; 3851 trace "syncing database to disk";
3696 BDB::db_env_txn_checkpoint $DB_ENV; 3852 BDB::db_env_txn_checkpoint $DB_ENV;
3697 3853
3698 # if anything goes wrong in here, we should simply crash as we already saved 3854 # if anything goes wrong in here, we should simply crash as we already saved
3699 3855
3700 warn "flushing outstanding aio requests"; 3856 trace "flushing outstanding aio requests";
3701 while (IO::AIO::nreqs || BDB::nreqs) { 3857 while (IO::AIO::nreqs || BDB::nreqs) {
3702 Coro::EV::timer_once 0.01; # let the sync_job do it's thing 3858 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3703 } 3859 }
3704 3860
3705 warn "cancelling all extension coros"; 3861 trace "cancelling all extension coros";
3706 $_->cancel for values %EXT_CORO; 3862 $_->cancel for values %EXT_CORO;
3707 %EXT_CORO = (); 3863 %EXT_CORO = ();
3708 3864
3709 warn "removing commands"; 3865 trace "removing commands";
3710 %COMMAND = (); 3866 %COMMAND = ();
3711 3867
3712 warn "removing ext/exti commands"; 3868 trace "removing ext/exti commands";
3713 %EXTCMD = (); 3869 %EXTCMD = ();
3714 %EXTICMD = (); 3870 %EXTICMD = ();
3715 3871
3716 warn "unloading/nuking all extensions"; 3872 trace "unloading/nuking all extensions";
3717 for my $pkg (@EXTS) { 3873 for my $pkg (@EXTS) {
3718 warn "... unloading $pkg"; 3874 trace "... unloading $pkg";
3719 3875
3720 if (my $cb = $pkg->can ("unload")) { 3876 if (my $cb = $pkg->can ("unload")) {
3721 eval { 3877 eval {
3722 $cb->($pkg); 3878 $cb->($pkg);
3723 1 3879 1
3724 } or warn "$pkg unloaded, but with errors: $@"; 3880 } or error "$pkg unloaded, but with errors: $@";
3725 } 3881 }
3726 3882
3727 warn "... clearing $pkg"; 3883 trace "... clearing $pkg";
3728 clear_package $pkg; 3884 clear_package $pkg;
3729 } 3885 }
3730 3886
3731 warn "unloading all perl modules loaded from $LIBDIR"; 3887 trace "unloading all perl modules loaded from $LIBDIR";
3732 while (my ($k, $v) = each %INC) { 3888 while (my ($k, $v) = each %INC) {
3733 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3889 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3734 3890
3735 warn "... unloading $k"; 3891 trace "... unloading $k";
3736 delete $INC{$k}; 3892 delete $INC{$k};
3737 3893
3738 $k =~ s/\.pm$//; 3894 $k =~ s/\.pm$//;
3739 $k =~ s/\//::/g; 3895 $k =~ s/\//::/g;
3740 3896
… …
3743 } 3899 }
3744 3900
3745 clear_package $k; 3901 clear_package $k;
3746 } 3902 }
3747 3903
3748 warn "getting rid of safe::, as good as possible"; 3904 trace "getting rid of safe::, as good as possible";
3749 clear_package "safe::$_" 3905 clear_package "safe::$_"
3750 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3906 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3751 3907
3752 warn "unloading cf.pm \"a bit\""; 3908 trace "unloading cf.pm \"a bit\"";
3753 delete $INC{"cf.pm"}; 3909 delete $INC{"cf.pm"};
3754 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 3910 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3755 3911
3756 # don't, removes xs symbols, too, 3912 # don't, removes xs symbols, too,
3757 # and global variables created in xs 3913 # and global variables created in xs
3758 #clear_package __PACKAGE__; 3914 #clear_package __PACKAGE__;
3759 3915
3760 warn "unload completed, starting to reload now"; 3916 info "unload completed, starting to reload now";
3761 3917
3762 warn "reloading cf.pm"; 3918 trace "reloading cf.pm";
3763 require cf; 3919 require cf;
3764 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3920 cf::_connect_to_perl_1;
3765 3921
3766 warn "loading config and database again"; 3922 trace "loading config and database again";
3767 cf::reload_config; 3923 cf::reload_config;
3768 3924
3769 warn "loading extensions"; 3925 trace "loading extensions";
3770 cf::load_extensions; 3926 cf::load_extensions;
3771 3927
3772 if ($REATTACH_ON_RELOAD) { 3928 if ($REATTACH_ON_RELOAD) {
3773 warn "reattaching attachments to objects/players"; 3929 trace "reattaching attachments to objects/players";
3774 _global_reattach; # objects, sockets 3930 _global_reattach; # objects, sockets
3775 warn "reattaching attachments to maps"; 3931 trace "reattaching attachments to maps";
3776 reattach $_ for values %MAP; 3932 reattach $_ for values %MAP;
3777 warn "reattaching attachments to players"; 3933 trace "reattaching attachments to players";
3778 reattach $_ for values %PLAYER; 3934 reattach $_ for values %PLAYER;
3779 } 3935 }
3780 3936
3781 warn "running post_init jobs"; 3937 trace "running post_init jobs";
3782 (pop @POST_INIT)->(1) while @POST_INIT; 3938 (pop @POST_INIT)->(1) while @POST_INIT;
3783 3939
3784 warn "leaving sync_job"; 3940 trace "leaving sync_job";
3785 3941
3786 1 3942 1
3787 } or do { 3943 } or do {
3788 warn $@; 3944 error $@;
3789 cf::cleanup "error while reloading, exiting."; 3945 cf::cleanup "error while reloading, exiting.";
3790 }; 3946 };
3791 3947
3792 warn "reloaded"; 3948 info "reloaded";
3793 --$RELOAD; 3949 --$RELOAD;
3794 } 3950 }
3795 3951
3796 $t1 = EV::time - $t1; 3952 $t1 = AE::time - $t1;
3797 warn "reload completed in ${t1}s\n"; 3953 info "reload completed in ${t1}s\n";
3798}; 3954};
3799 3955
3800our $RELOAD_WATCHER; # used only during reload 3956our $RELOAD_WATCHER; # used only during reload
3801 3957
3802sub reload_perl() { 3958sub reload_perl() {
… …
3804 # coro crashes during coro_state_free->destroy here. 3960 # coro crashes during coro_state_free->destroy here.
3805 3961
3806 $RELOAD_WATCHER ||= cf::async { 3962 $RELOAD_WATCHER ||= cf::async {
3807 Coro::AIO::aio_wait cache_extensions; 3963 Coro::AIO::aio_wait cache_extensions;
3808 3964
3809 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 3965 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3810 do_reload_perl; 3966 do_reload_perl;
3811 undef $RELOAD_WATCHER; 3967 undef $RELOAD_WATCHER;
3812 }; 3968 };
3813 }; 3969 };
3814} 3970}
… …
3831 3987
3832our @WAIT_FOR_TICK; 3988our @WAIT_FOR_TICK;
3833our @WAIT_FOR_TICK_BEGIN; 3989our @WAIT_FOR_TICK_BEGIN;
3834 3990
3835sub wait_for_tick { 3991sub wait_for_tick {
3836 return if tick_inhibit || $Coro::current == $Coro::main; 3992 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3837 3993
3838 my $signal = new Coro::Signal; 3994 my $signal = new Coro::Signal;
3839 push @WAIT_FOR_TICK, $signal; 3995 push @WAIT_FOR_TICK, $signal;
3840 $signal->wait; 3996 $signal->wait;
3841} 3997}
3842 3998
3843sub wait_for_tick_begin { 3999sub wait_for_tick_begin {
3844 return if tick_inhibit || $Coro::current == $Coro::main; 4000 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3845 4001
3846 my $signal = new Coro::Signal; 4002 my $signal = new Coro::Signal;
3847 push @WAIT_FOR_TICK_BEGIN, $signal; 4003 push @WAIT_FOR_TICK_BEGIN, $signal;
3848 $signal->wait; 4004 $signal->wait;
3849} 4005}
… …
3855 return; 4011 return;
3856 } 4012 }
3857 4013
3858 cf::server_tick; # one server iteration 4014 cf::server_tick; # one server iteration
3859 4015
4016 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4017
3860 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4018 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3861 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4019 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3862 Coro::async_pool { 4020 Coro::async_pool {
3863 $Coro::current->{desc} = "runtime saver"; 4021 $Coro::current->{desc} = "runtime saver";
3864 write_runtime_sync 4022 write_runtime_sync
3865 or warn "ERROR: unable to write runtime file: $!"; 4023 or error "ERROR: unable to write runtime file: $!";
3866 }; 4024 };
3867 } 4025 }
3868 4026
3869 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4027 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3870 $sig->send; 4028 $sig->send;
… …
3878 4036
3879 if (0) { 4037 if (0) {
3880 if ($NEXT_TICK) { 4038 if ($NEXT_TICK) {
3881 my $jitter = $TICK_START - $NEXT_TICK; 4039 my $jitter = $TICK_START - $NEXT_TICK;
3882 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4040 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3883 warn "jitter $JITTER\n";#d# 4041 debug "jitter $JITTER\n";#d#
3884 } 4042 }
3885 } 4043 }
3886} 4044}
3887 4045
3888{ 4046{
3889 # configure BDB 4047 # configure BDB
3890 4048
3891 BDB::min_parallel 8; 4049 BDB::min_parallel 16;
3892 BDB::max_poll_reqs $TICK * 0.1; 4050 BDB::max_poll_reqs $TICK * 0.1;
3893 $AnyEvent::BDB::WATCHER->priority (1); 4051 $AnyEvent::BDB::WATCHER->priority (1);
3894 4052
3895 unless ($DB_ENV) { 4053 unless ($DB_ENV) {
3896 $DB_ENV = BDB::db_env_create; 4054 $DB_ENV = BDB::db_env_create;
… …
3898 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7; 4056 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3899 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7; 4057 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3900 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 4058 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3901 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 4059 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3902 4060
4061 (Coro::async { # async to keep sync_job from complaining
3903 cf::sync_job { 4062 cf::sync_job {
3904 eval { 4063 eval {
3905 BDB::db_env_open 4064 BDB::db_env_open
3906 $DB_ENV, 4065 $DB_ENV,
3907 $BDBDIR, 4066 $BDBDIR,
3908 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 4067 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3909 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4068 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3910 0666; 4069 0666;
3911 4070
3912 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4071 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
4072 };
4073
4074 cf::cleanup "db_env_open(db): $@" if $@;
3913 }; 4075 };
3914 4076 })->join;
3915 cf::cleanup "db_env_open(db): $@" if $@;
3916 };
3917 } 4077 }
3918 4078
3919 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub { 4079 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3920 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 4080 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3921 }; 4081 };
… …
3977 } 4137 }
3978} 4138}
3979 4139
3980# load additional modules 4140# load additional modules
3981require "cf/$_.pm" for @EXTRA_MODULES; 4141require "cf/$_.pm" for @EXTRA_MODULES;
4142cf::_connect_to_perl_2;
3982 4143
3983END { cf::emergency_save } 4144END { cf::emergency_save }
3984 4145
39851 41461
3986 4147

Diff Legend

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