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.464 by root, Thu Jan 1 18:35:48 2009 UTC vs.
Revision 1.528 by root, Fri Apr 23 04:42:12 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;
26use strict "vars", "subs"; 27use strict qw(vars subs);
27 28
28use Symbol; 29use Symbol;
29use List::Util; 30use List::Util;
30use Socket; 31use Socket;
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
… …
71$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
72 73
73# make sure c-lzf reinitialises itself 74# make sure c-lzf reinitialises itself
74Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve"; 75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
75Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
77
78# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
76 80
77sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
78 82
79our %COMMAND = (); 83our %COMMAND = ();
80our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
… …
85our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
86our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
87 91
88our $RELOAD; # number of reloads so far, non-zero while in reload 92our $RELOAD; # number of reloads so far, non-zero while in reload
89our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
90 96
91our $CONFDIR = confdir; 97our $CONFDIR = confdir;
92our $DATADIR = datadir; 98our $DATADIR = datadir;
93our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
94our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
… …
102our $PIDFILE = "$LOCALDIR/pid"; 108our $PIDFILE = "$LOCALDIR/pid";
103our $RUNTIMEFILE = "$LOCALDIR/runtime"; 109our $RUNTIMEFILE = "$LOCALDIR/runtime";
104 110
105our %RESOURCE; 111our %RESOURCE;
106 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;
118
107our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
108our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
109our $NEXT_TICK; 121our $NEXT_TICK;
110our $USE_FSYNC = 1; # use fsync to write maps - default off 122our $USE_FSYNC = 1; # use fsync to write maps - default on
111 123
112our $BDB_DEADLOCK_WATCHER; 124our $BDB_DEADLOCK_WATCHER;
113our $BDB_CHECKPOINT_WATCHER; 125our $BDB_CHECKPOINT_WATCHER;
114our $BDB_TRICKLE_WATCHER; 126our $BDB_TRICKLE_WATCHER;
115our $DB_ENV; 127our $DB_ENV;
116 128
129our @EXTRA_MODULES = qw(pod match mapscript);
130
117our %CFG; 131our %CFG;
118 132
119our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
120our $RUNTIME; 134our $RUNTIME;
121our $NOW; 135our $NOW;
… …
132our $JITTER; # average jitter 146our $JITTER; # average jitter
133our $TICK_START; # for load detecting purposes 147our $TICK_START; # for load detecting purposes
134 148
135our @POST_INIT; 149our @POST_INIT;
136 150
137our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow) 151our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
152our $REALLY_UNLOOP; # never set to true, please :)
138 153
139binmode STDOUT; 154binmode STDOUT;
140binmode STDERR; 155binmode STDERR;
141 156
142# read virtual server time, if available 157# read virtual server time, if available
… …
144 open my $fh, "<", $RUNTIMEFILE 159 open my $fh, "<", $RUNTIMEFILE
145 or die "unable to read $RUNTIMEFILE file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
146 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
147} 162}
148 163
164eval "sub TICK() { $TICK } 1" or die;
165
149mkdir $_ 166mkdir $_
150 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
151 168
152our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
153 170
154sub cf::map::normalise; 171sub cf::map::normalise;
172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
176
177#############################################################################
178
179%REFLECT = ();
180for (@REFLECT) {
181 my $reflect = JSON::XS::decode_json $_;
182 $REFLECT{$reflect->{class}} = $reflect;
183}
184
185# this is decidedly evil
186$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
155 187
156############################################################################# 188#############################################################################
157 189
158=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
159 191
… …
206returns 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
207per 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.
208 240
209=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
210 242
211This array contains the results of the last C<invoke ()> call. When 243This array contains the results of the last C<invoke ()> call. When
212C<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
213that call. 245that call.
214 246
247=item %cf::REFLECT
248
249Contains, for each (C++) class name, a hash reference with information
250about object members (methods, scalars, arrays and flags) and other
251metadata, which is useful for introspection.
252
215=back 253=back
216 254
217=cut 255=cut
218 256
219BEGIN { 257$Coro::State::WARNHOOK = sub {
220 *CORE::GLOBAL::warn = sub {
221 my $msg = join "", @_; 258 my $msg = join "", @_;
222 259
223 $msg .= "\n" 260 $msg .= "\n"
224 unless $msg =~ /\n$/; 261 unless $msg =~ /\n$/;
225 262
226 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 263 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
227 264
228 LOG llevError, $msg; 265 LOG llevError, $msg;
229 }; 266};
230}
231 267
232$Coro::State::DIEHOOK = sub { 268$Coro::State::DIEHOOK = sub {
233 return unless $^S eq 0; # "eq", not "==" 269 return unless $^S eq 0; # "eq", not "=="
234 270
235 if ($Coro::current == $Coro::main) {#d# 271 warn Carp::longmess $_[0];
272
273 if (in_main) {#d#
236 warn "DIEHOOK called in main context, Coro bug?\n";#d# 274 warn "DIEHOOK called in main context, Coro bug?\n";#d#
237 return;#d# 275 return;#d#
238 }#d# 276 }#d#
239 277
240 # kill coroutine otherwise 278 # kill coroutine otherwise
241 warn Carp::longmess $_[0];
242 Coro::terminate 279 Coro::terminate
243}; 280};
244
245$SIG{__DIE__} = sub { }; #d#?
246 281
247@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 282@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
248@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 283@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
249@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 284@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
250@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 285@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
264)) { 299)) {
265 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 300 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
266} 301}
267 302
268$EV::DIED = sub { 303$EV::DIED = sub {
269 warn "error in event callback: @_"; 304 Carp::cluck "error in event callback: @_";
270}; 305};
271 306
272############################################################################# 307#############################################################################
273 308
274=head2 UTILITY FUNCTIONS 309=head2 UTILITY FUNCTIONS
… …
371} 406}
372 407
373=item cf::periodic $interval, $cb 408=item cf::periodic $interval, $cb
374 409
375Like EV::periodic, but randomly selects a starting point so that the actions 410Like EV::periodic, but randomly selects a starting point so that the actions
376get spread over timer. 411get spread over time.
377 412
378=cut 413=cut
379 414
380sub periodic($$) { 415sub periodic($$) {
381 my ($interval, $cb) = @_; 416 my ($interval, $cb) = @_;
… …
398 433
399=cut 434=cut
400 435
401our @SLOT_QUEUE; 436our @SLOT_QUEUE;
402our $SLOT_QUEUE; 437our $SLOT_QUEUE;
438our $SLOT_DECAY = 0.9;
403 439
404$SLOT_QUEUE->cancel if $SLOT_QUEUE; 440$SLOT_QUEUE->cancel if $SLOT_QUEUE;
405$SLOT_QUEUE = Coro::async { 441$SLOT_QUEUE = Coro::async {
406 $Coro::current->desc ("timeslot manager"); 442 $Coro::current->desc ("timeslot manager");
407 443
408 my $signal = new Coro::Signal; 444 my $signal = new Coro::Signal;
445 my $busy;
409 446
410 while () { 447 while () {
411 next_job: 448 next_job:
449
412 my $avail = cf::till_tick; 450 my $avail = cf::till_tick;
413 if ($avail > 0.01) { 451
414 for (0 .. $#SLOT_QUEUE) { 452 for (0 .. $#SLOT_QUEUE) {
415 if ($SLOT_QUEUE[$_][0] < $avail) { 453 if ($SLOT_QUEUE[$_][0] <= $avail) {
454 $busy = 0;
416 my $job = splice @SLOT_QUEUE, $_, 1, (); 455 my $job = splice @SLOT_QUEUE, $_, 1, ();
417 $job->[2]->send; 456 $job->[2]->send;
418 Coro::cede; 457 Coro::cede;
419 goto next_job; 458 goto next_job;
420 } 459 } else {
460 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
421 } 461 }
422 } 462 }
423 463
424 if (@SLOT_QUEUE) { 464 if (@SLOT_QUEUE) {
425 # we do not use wait_for_tick() as it returns immediately when tick is inactive 465 # we do not use wait_for_tick() as it returns immediately when tick is inactive
426 push @cf::WAIT_FOR_TICK, $signal; 466 push @cf::WAIT_FOR_TICK, $signal;
427 $signal->wait; 467 $signal->wait;
428 } else { 468 } else {
469 $busy = 0;
429 Coro::schedule; 470 Coro::schedule;
430 } 471 }
431 } 472 }
432}; 473};
433 474
434sub get_slot($;$$) { 475sub get_slot($;$$) {
435 return if tick_inhibit || $Coro::current == $Coro::main; 476 return if tick_inhibit || $Coro::current == $Coro::main;
436 477
437 my ($time, $pri, $name) = @_; 478 my ($time, $pri, $name) = @_;
438 479
439 $time = $TICK * .6 if $time > $TICK * .6; 480 $time = clamp $time, 0.01, $TICK * .6;
481
440 my $sig = new Coro::Signal; 482 my $sig = new Coro::Signal;
441 483
442 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 484 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
443 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 485 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
444 $SLOT_QUEUE->ready; 486 $SLOT_QUEUE->ready;
… …
471 513
472sub sync_job(&) { 514sub sync_job(&) {
473 my ($job) = @_; 515 my ($job) = @_;
474 516
475 if ($Coro::current == $Coro::main) { 517 if ($Coro::current == $Coro::main) {
476 my $time = EV::time; 518 my $time = AE::time;
477 519
478 # this is the main coro, too bad, we have to block 520 # this is the main coro, too bad, we have to block
479 # till the operation succeeds, freezing the server :/ 521 # till the operation succeeds, freezing the server :/
480 522
481 LOG llevError, Carp::longmess "sync job";#d# 523 LOG llevError, Carp::longmess "sync job";#d#
… …
498 } else { 540 } else {
499 EV::loop EV::LOOP_ONESHOT; 541 EV::loop EV::LOOP_ONESHOT;
500 } 542 }
501 } 543 }
502 544
503 my $time = EV::time - $time; 545 my $time = AE::time - $time;
504 546
505 $TICK_START += $time; # do not account sync jobs to server load 547 $TICK_START += $time; # do not account sync jobs to server load
506 548
507 wantarray ? @res : $res[0] 549 wantarray ? @res : $res[0]
508 } else { 550 } else {
… …
552 reset_signals; 594 reset_signals;
553 &$cb 595 &$cb
554 }, @args; 596 }, @args;
555 597
556 wantarray ? @res : $res[-1] 598 wantarray ? @res : $res[-1]
599}
600
601sub objinfo {
602 (
603 "counter value" => cf::object::object_count,
604 "objects created" => cf::object::create_count,
605 "objects destroyed" => cf::object::destroy_count,
606 "freelist size" => cf::object::free_count,
607 "allocated objects" => cf::object::objects_size,
608 "active objects" => cf::object::actives_size,
609 )
557} 610}
558 611
559=item $coin = coin_from_name $name 612=item $coin = coin_from_name $name
560 613
561=cut 614=cut
… …
1142 1195
1143 sync_job { 1196 sync_job {
1144 if (length $$rdata) { 1197 if (length $$rdata) {
1145 utf8::decode (my $decname = $filename); 1198 utf8::decode (my $decname = $filename);
1146 warn sprintf "saving %s (%d,%d)\n", 1199 warn sprintf "saving %s (%d,%d)\n",
1147 $decname, length $$rdata, scalar @$objs; 1200 $decname, length $$rdata, scalar @$objs
1201 if $VERBOSE_IO;
1148 1202
1149 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1203 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1150 aio_chmod $fh, SAVE_MODE; 1204 aio_chmod $fh, SAVE_MODE;
1151 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1205 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1152 aio_fsync $fh if $cf::USE_FSYNC; 1206 if ($cf::USE_FSYNC) {
1207 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1208 aio_fsync $fh;
1209 }
1153 aio_close $fh; 1210 aio_close $fh;
1154 1211
1155 if (@$objs) { 1212 if (@$objs) {
1156 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1213 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1157 aio_chmod $fh, SAVE_MODE; 1214 aio_chmod $fh, SAVE_MODE;
1158 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1215 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1159 aio_write $fh, 0, (length $data), $data, 0; 1216 aio_write $fh, 0, (length $data), $data, 0;
1160 aio_fsync $fh if $cf::USE_FSYNC; 1217 if ($cf::USE_FSYNC) {
1218 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1219 aio_fsync $fh;
1220 }
1161 aio_close $fh; 1221 aio_close $fh;
1162 aio_rename "$filename.pst~", "$filename.pst"; 1222 aio_rename "$filename.pst~", "$filename.pst";
1163 } 1223 }
1164 } else { 1224 } else {
1165 aio_unlink "$filename.pst"; 1225 aio_unlink "$filename.pst";
… …
1203 $av = $st->{objs}; 1263 $av = $st->{objs};
1204 } 1264 }
1205 1265
1206 utf8::decode (my $decname = $filename); 1266 utf8::decode (my $decname = $filename);
1207 warn sprintf "loading %s (%d,%d)\n", 1267 warn sprintf "loading %s (%d,%d)\n",
1208 $decname, length $data, scalar @{$av || []}; 1268 $decname, length $data, scalar @{$av || []}
1269 if $VERBOSE_IO;
1209 1270
1210 ($data, $av) 1271 ($data, $av)
1211} 1272}
1212 1273
1213=head2 COMMAND CALLBACKS 1274=head2 COMMAND CALLBACKS
… …
1272} 1333}
1273 1334
1274use File::Glob (); 1335use File::Glob ();
1275 1336
1276cf::player->attach ( 1337cf::player->attach (
1277 on_command => sub { 1338 on_unknown_command => sub {
1278 my ($pl, $name, $params) = @_; 1339 my ($pl, $name, $params) = @_;
1279 1340
1280 my $cb = $COMMAND{$name} 1341 my $cb = $COMMAND{$name}
1281 or return; 1342 or return;
1282 1343
… …
1316 1377
1317# "readahead" all extensions 1378# "readahead" all extensions
1318sub cache_extensions { 1379sub cache_extensions {
1319 my $grp = IO::AIO::aio_group; 1380 my $grp = IO::AIO::aio_group;
1320 1381
1321 add $grp IO::AIO::aio_readdir $LIBDIR, sub { 1382 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1322 for (grep /\.ext$/, @{$_[0]}) { 1383 for (grep /\.ext$/, @{$_[0]}) {
1323 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data; 1384 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1324 } 1385 }
1325 }; 1386 };
1326 1387
… …
1361 . "\n};\n1"; 1422 . "\n};\n1";
1362 1423
1363 $todo{$base} = \%ext; 1424 $todo{$base} = \%ext;
1364 } 1425 }
1365 1426
1427 my $pass = 0;
1366 my %done; 1428 my %done;
1367 while (%todo) { 1429 while (%todo) {
1368 my $progress; 1430 my $progress;
1369 1431
1432 ++$pass;
1433
1434 ext:
1370 while (my ($k, $v) = each %todo) { 1435 while (my ($k, $v) = each %todo) {
1371 for (split /,\s*/, $v->{meta}{depends}) { 1436 for (split /,\s*/, $v->{meta}{depends}) {
1372 goto skip 1437 next ext
1373 unless exists $done{$_}; 1438 unless exists $done{$_};
1374 } 1439 }
1375 1440
1376 warn "... loading '$k' into '$v->{pkg}'\n"; 1441 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1377 1442
1378 unless (eval $v->{source}) { 1443 my $active = eval $v->{source};
1444
1445 if (length $@) {
1379 my $msg = $@ ? "$v->{path}: $@\n" 1446 warn "$v->{path}: $@\n";
1380 : "$v->{base}: extension inactive.\n";
1381 1447
1382 if (exists $v->{meta}{mandatory}) {
1383 warn $msg;
1384 cf::cleanup "mandatory extension failed to load, exiting."; 1448 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1385 } 1449 if exists $v->{meta}{mandatory};
1386 1450
1387 warn $msg; 1451 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1452 delete $todo{$k};
1453 } else {
1454 $done{$k} = delete $todo{$k};
1455 push @EXTS, $v->{pkg};
1456 $progress = 1;
1457
1458 warn "$v->{base}: extension inactive.\n"
1459 unless $active;
1388 } 1460 }
1389
1390 $done{$k} = delete $todo{$k};
1391 push @EXTS, $v->{pkg};
1392 $progress = 1;
1393 } 1461 }
1394 1462
1395 skip: 1463 unless ($progress) {
1396 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1464 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1397 unless $progress; 1465
1466 while (my ($k, $v) = each %todo) {
1467 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1468 if exists $v->{meta}{mandatory};
1469 }
1470 }
1398 } 1471 }
1399 }; 1472 };
1400} 1473}
1401 1474
1402############################################################################# 1475#############################################################################
… …
1486 $cf::PLAYER{$login} = $pl 1559 $cf::PLAYER{$login} = $pl
1487 } 1560 }
1488 } 1561 }
1489} 1562}
1490 1563
1564cf::player->attach (
1565 on_load => sub {
1566 my ($pl, $path) = @_;
1567
1568 # restore slots saved in save, below
1569 my $slots = delete $pl->{_slots};
1570
1571 $pl->ob->current_weapon ($slots->[0]);
1572 $pl->combat_ob ($slots->[1]);
1573 $pl->ranged_ob ($slots->[2]);
1574 },
1575);
1576
1491sub save($) { 1577sub save($) {
1492 my ($pl) = @_; 1578 my ($pl) = @_;
1493 1579
1494 return if $pl->{deny_save}; 1580 return if $pl->{deny_save};
1495 1581
… …
1500 1586
1501 aio_mkdir playerdir $pl, 0770; 1587 aio_mkdir playerdir $pl, 0770;
1502 $pl->{last_save} = $cf::RUNTIME; 1588 $pl->{last_save} = $cf::RUNTIME;
1503 1589
1504 cf::get_slot 0.01; 1590 cf::get_slot 0.01;
1591
1592 # save slots, to be restored later
1593 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1505 1594
1506 $pl->save_pl ($path); 1595 $pl->save_pl ($path);
1507 cf::cede_to_tick; 1596 cf::cede_to_tick;
1508} 1597}
1509 1598
… …
1611 \@logins 1700 \@logins
1612} 1701}
1613 1702
1614=item $player->maps 1703=item $player->maps
1615 1704
1705=item cf::player::maps $login
1706
1616Returns an arrayref of map paths that are private for this 1707Returns an arrayref of map paths that are private for this
1617player. May block. 1708player. May block.
1618 1709
1619=cut 1710=cut
1620 1711
… …
1682=cut 1773=cut
1683 1774
1684sub find_by_path($) { 1775sub find_by_path($) {
1685 my ($path) = @_; 1776 my ($path) = @_;
1686 1777
1778 $path =~ s/^~[^\/]*//; # skip ~login
1779
1687 my ($match, $specificity); 1780 my ($match, $specificity);
1688 1781
1689 for my $region (list) { 1782 for my $region (list) {
1690 if ($region->{match} && $path =~ $region->{match}) { 1783 if ($region->{match} && $path =~ $region->{match}) {
1691 ($match, $specificity) = ($region, $region->specificity) 1784 ($match, $specificity) = ($region, $region->specificity)
… …
1722 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1815 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1723 1816
1724 # mit "rum" bekleckern, nicht 1817 # mit "rum" bekleckern, nicht
1725 $self->_create_random_map ( 1818 $self->_create_random_map (
1726 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1819 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1727 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1820 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1728 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1821 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1729 $rmp->{exit_on_final_map}, 1822 $rmp->{exit_on_final_map},
1730 $rmp->{xsize}, $rmp->{ysize}, 1823 $rmp->{xsize}, $rmp->{ysize},
1731 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1824 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1732 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1825 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1754 1847
1755 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1848 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1756} 1849}
1757 1850
1758# also paths starting with '/' 1851# also paths starting with '/'
1759$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1852$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1760 1853
1761sub thawer_merge { 1854sub thawer_merge {
1762 my ($self, $merge) = @_; 1855 my ($self, $merge) = @_;
1763 1856
1764 # we have to keep some variables in memory intact 1857 # we have to keep some variables in memory intact
… …
1978 2071
1979 $cf::MAP{$path} = $map 2072 $cf::MAP{$path} = $map
1980 } 2073 }
1981} 2074}
1982 2075
1983sub pre_load { } 2076sub pre_load { }
1984sub post_load { } 2077#sub post_load { } # XS
1985 2078
1986sub load { 2079sub load {
1987 my ($self) = @_; 2080 my ($self) = @_;
1988 2081
1989 local $self->{deny_reset} = 1; # loading can take a long time 2082 local $self->{deny_reset} = 1; # loading can take a long time
… …
2046 } 2139 }
2047 2140
2048 $self->post_load; 2141 $self->post_load;
2049} 2142}
2050 2143
2144# customize the map for a given player, i.e.
2145# return the _real_ map. used by e.g. per-player
2146# maps to change the path to ~playername/mappath
2051sub customise_for { 2147sub customise_for {
2052 my ($self, $ob) = @_; 2148 my ($self, $ob) = @_;
2053 2149
2054 return find "~" . $ob->name . "/" . $self->{path} 2150 return find "~" . $ob->name . "/" . $self->{path}
2055 if $self->per_player; 2151 if $self->per_player;
… …
2071 or next; 2167 or next;
2072 $neigh = find $neigh, $map 2168 $neigh = find $neigh, $map
2073 or next; 2169 or next;
2074 $neigh->load; 2170 $neigh->load;
2075 2171
2172 # now find the diagonal neighbours
2076 push @neigh, 2173 push @neigh,
2077 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2174 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2078 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2175 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2079 } 2176 }
2080 2177
… …
2132 $MAP_PREFETCHER->prio (6); 2229 $MAP_PREFETCHER->prio (6);
2133 2230
2134 () 2231 ()
2135} 2232}
2136 2233
2234# common code, used by both ->save and ->swapout
2137sub save { 2235sub _save {
2138 my ($self) = @_; 2236 my ($self) = @_;
2139
2140 my $lock = cf::lock_acquire "map_data:$self->{path}";
2141 2237
2142 $self->{last_save} = $cf::RUNTIME; 2238 $self->{last_save} = $cf::RUNTIME;
2143 2239
2144 return unless $self->dirty; 2240 return unless $self->dirty;
2145 2241
… …
2165 } else { 2261 } else {
2166 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2262 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2167 } 2263 }
2168} 2264}
2169 2265
2266sub save {
2267 my ($self) = @_;
2268
2269 my $lock = cf::lock_acquire "map_data:$self->{path}";
2270
2271 $self->_save;
2272}
2273
2170sub swap_out { 2274sub swap_out {
2171 my ($self) = @_; 2275 my ($self) = @_;
2172 2276
2173 # save first because save cedes
2174 $self->save;
2175
2176 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2277 my $lock = cf::lock_acquire "map_data:$self->{path}";
2177 2278
2178 return if $self->players;
2179 return if $self->in_memory != cf::MAP_ACTIVE; 2279 return if $self->in_memory != cf::MAP_ACTIVE;
2180 return if $self->{deny_save}; 2280 return if $self->{deny_save};
2281 return if $self->players;
2181 2282
2283 # first deactivate the map and "unlink" it from the core
2284 $self->deactivate;
2285 $_->clear_links_to ($self) for values %cf::MAP;
2182 $self->in_memory (cf::MAP_SWAPPED); 2286 $self->in_memory (cf::MAP_SWAPPED);
2287
2288 # then atomically save
2289 $self->_save;
2290
2291 # then free the map
2292 $self->clear;
2293}
2294
2295sub reset_at {
2296 my ($self) = @_;
2297
2298 # TODO: safety, remove and allow resettable per-player maps
2299 return 1e99 if $self->{deny_reset};
2300
2301 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2302 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2303
2304 $time + $to
2305}
2306
2307sub should_reset {
2308 my ($self) = @_;
2309
2310 $self->reset_at <= $cf::RUNTIME
2311}
2312
2313sub reset {
2314 my ($self) = @_;
2315
2316 my $lock = cf::lock_acquire "map_data:$self->{path}";
2317
2318 return if $self->players;
2319
2320 warn "resetting map ", $self->path, "\n";
2321
2322 $self->in_memory (cf::MAP_SWAPPED);
2323
2324 # need to save uniques path
2325 unless ($self->{deny_save}) {
2326 my $uniq = $self->uniq_path; utf8::encode $uniq;
2327
2328 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2329 if $uniq;
2330 }
2331
2332 delete $cf::MAP{$self->path};
2183 2333
2184 $self->deactivate; 2334 $self->deactivate;
2185 $_->clear_links_to ($self) for values %cf::MAP; 2335 $_->clear_links_to ($self) for values %cf::MAP;
2186 $self->clear; 2336 $self->clear;
2187}
2188
2189sub reset_at {
2190 my ($self) = @_;
2191
2192 # TODO: safety, remove and allow resettable per-player maps
2193 return 1e99 if $self->{deny_reset};
2194
2195 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2196 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2197
2198 $time + $to
2199}
2200
2201sub should_reset {
2202 my ($self) = @_;
2203
2204 $self->reset_at <= $cf::RUNTIME
2205}
2206
2207sub reset {
2208 my ($self) = @_;
2209
2210 my $lock = cf::lock_acquire "map_data:$self->{path}";
2211
2212 return if $self->players;
2213
2214 warn "resetting map ", $self->path;
2215
2216 $self->in_memory (cf::MAP_SWAPPED);
2217
2218 # need to save uniques path
2219 unless ($self->{deny_save}) {
2220 my $uniq = $self->uniq_path; utf8::encode $uniq;
2221
2222 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2223 if $uniq;
2224 }
2225
2226 delete $cf::MAP{$self->path};
2227
2228 $self->deactivate;
2229 $_->clear_links_to ($self) for values %cf::MAP;
2230 $self->clear;
2231 2337
2232 $self->unlink_save; 2338 $self->unlink_save;
2233 $self->destroy; 2339 $self->destroy;
2234} 2340}
2235 2341
… …
2243 2349
2244 delete $cf::MAP{$self->path}; 2350 delete $cf::MAP{$self->path};
2245 2351
2246 $self->unlink_save; 2352 $self->unlink_save;
2247 2353
2248 bless $self, "cf::map"; 2354 bless $self, "cf::map::wrap";
2249 delete $self->{deny_reset}; 2355 delete $self->{deny_reset};
2250 $self->{deny_save} = 1; 2356 $self->{deny_save} = 1;
2251 $self->reset_timeout (1); 2357 $self->reset_timeout (1);
2252 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2358 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2253 2359
… …
2310 : normalise $_ 2416 : normalise $_
2311 } @{ aio_readdir $UNIQUEDIR or [] } 2417 } @{ aio_readdir $UNIQUEDIR or [] }
2312 ] 2418 ]
2313} 2419}
2314 2420
2421=item cf::map::static_maps
2422
2423Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2424file in the shared directory excluding F</styles> and F</editor>). May
2425block.
2426
2427=cut
2428
2429sub static_maps() {
2430 my @dirs = "";
2431 my @maps;
2432
2433 while (@dirs) {
2434 my $dir = shift @dirs;
2435
2436 next if $dir eq "/styles" || $dir eq "/editor";
2437
2438 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2439 or return;
2440
2441 for (@$files) {
2442 s/\.map$// or next;
2443 utf8::decode $_;
2444 push @maps, "$dir/$_";
2445 }
2446
2447 push @dirs, map "$dir/$_", @$dirs;
2448 }
2449
2450 \@maps
2451}
2452
2315=back 2453=back
2316 2454
2317=head3 cf::object 2455=head3 cf::object
2318 2456
2319=cut 2457=cut
… …
2384 2522
2385our $SAY_CHANNEL = { 2523our $SAY_CHANNEL = {
2386 id => "say", 2524 id => "say",
2387 title => "Map", 2525 title => "Map",
2388 reply => "say ", 2526 reply => "say ",
2389 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2527 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2390}; 2528};
2391 2529
2392our $CHAT_CHANNEL = { 2530our $CHAT_CHANNEL = {
2393 id => "chat", 2531 id => "chat",
2394 title => "Chat", 2532 title => "Chat",
… …
2451 2589
2452Freezes the player and moves him/her to a special map (C<{link}>). 2590Freezes the player and moves him/her to a special map (C<{link}>).
2453 2591
2454The player should be reasonably safe there for short amounts of time (e.g. 2592The player should be reasonably safe there for short amounts of time (e.g.
2455for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2593for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2456though, as the palyer cannot control the character while it is on the link 2594though, as the player cannot control the character while it is on the link
2457map. 2595map.
2458 2596
2459Will never block. 2597Will never block.
2460 2598
2461=item $player_object->leave_link ($map, $x, $y) 2599=item $player_object->leave_link ($map, $x, $y)
… …
2482sub cf::object::player::enter_link { 2620sub cf::object::player::enter_link {
2483 my ($self) = @_; 2621 my ($self) = @_;
2484 2622
2485 $self->deactivate_recursive; 2623 $self->deactivate_recursive;
2486 2624
2625 ++$self->{_link_recursion};
2626
2487 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2627 return if UNIVERSAL::isa $self->map, "ext::map_link";
2488 2628
2489 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2629 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2490 if $self->map && $self->map->{path} ne "{link}"; 2630 if $self->map && $self->map->{path} ne "{link}";
2491 2631
2492 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2632 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2493} 2633}
2494 2634
2495sub cf::object::player::leave_link { 2635sub cf::object::player::leave_link {
2496 my ($self, $map, $x, $y) = @_; 2636 my ($self, $map, $x, $y) = @_;
2497 2637
… …
2514 ($x, $y) = (-1, -1) 2654 ($x, $y) = (-1, -1)
2515 unless (defined $x) && (defined $y); 2655 unless (defined $x) && (defined $y);
2516 2656
2517 # use -1 or undef as default coordinates, not 0, 0 2657 # use -1 or undef as default coordinates, not 0, 0
2518 ($x, $y) = ($map->enter_x, $map->enter_y) 2658 ($x, $y) = ($map->enter_x, $map->enter_y)
2519 if $x <=0 && $y <= 0; 2659 if $x <= 0 && $y <= 0;
2520 2660
2521 $map->load; 2661 $map->load;
2522 $map->load_neighbours; 2662 $map->load_neighbours;
2523 2663
2524 return unless $self->contr->active; 2664 return unless $self->contr->active;
2525 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2526 $self->activate_recursive;
2527 2665
2528 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2666 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2529 $self->enter_map ($map, $x, $y); 2667 if ($self->enter_map ($map, $x, $y)) {
2530} 2668 # entering was successful
2669 delete $self->{_link_recursion};
2670 # only activate afterwards, to support waiting in hooks
2671 $self->activate_recursive;
2672 }
2531 2673
2674}
2675
2532=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2676=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2533 2677
2534Moves the player to the given map-path and coordinates by first freezing 2678Moves the player to the given map-path and coordinates by first freezing
2535her, loading and preparing them map, calling the provided $check callback 2679her, loading and preparing them map, calling the provided $check callback
2536that has to return the map if sucecssful, and then unfreezes the player on 2680that has to return the map if sucecssful, and then unfreezes the player on
2537the new (success) or old (failed) map position. In either case, $done will 2681the new (success) or old (failed) map position. In either case, $done will
… …
2544 2688
2545our $GOTOGEN; 2689our $GOTOGEN;
2546 2690
2547sub cf::object::player::goto { 2691sub cf::object::player::goto {
2548 my ($self, $path, $x, $y, $check, $done) = @_; 2692 my ($self, $path, $x, $y, $check, $done) = @_;
2693
2694 if ($self->{_link_recursion} >= $MAX_LINKS) {
2695 warn "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2696 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2697 ($path, $x, $y) = @$EMERGENCY_POSITION;
2698 }
2549 2699
2550 # do generation counting so two concurrent goto's will be executed in-order 2700 # do generation counting so two concurrent goto's will be executed in-order
2551 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2701 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2552 2702
2553 $self->enter_link; 2703 $self->enter_link;
… …
2577 my $map = eval { 2727 my $map = eval {
2578 my $map = defined $path ? cf::map::find $path : undef; 2728 my $map = defined $path ? cf::map::find $path : undef;
2579 2729
2580 if ($map) { 2730 if ($map) {
2581 $map = $map->customise_for ($self); 2731 $map = $map->customise_for ($self);
2582 $map = $check->($map) if $check && $map; 2732 $map = $check->($map, $x, $y, $self) if $check && $map;
2583 } else { 2733 } else {
2584 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2734 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2585 } 2735 }
2586 2736
2587 $map 2737 $map
… …
2595 if ($gen == $self->{_goto_generation}) { 2745 if ($gen == $self->{_goto_generation}) {
2596 delete $self->{_goto_generation}; 2746 delete $self->{_goto_generation};
2597 $self->leave_link ($map, $x, $y); 2747 $self->leave_link ($map, $x, $y);
2598 } 2748 }
2599 2749
2600 $done->() if $done; 2750 $done->($self) if $done;
2601 })->prio (1); 2751 })->prio (1);
2602} 2752}
2603 2753
2604=item $player_object->enter_exit ($exit_object) 2754=item $player_object->enter_exit ($exit_object)
2605 2755
… …
2722 2872
2723 utf8::encode $text; 2873 utf8::encode $text;
2724 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2874 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2725} 2875}
2726 2876
2877=item $client->send_big_packet ($pkt)
2878
2879Like C<send_packet>, but tries to compress large packets, and fragments
2880them as required.
2881
2882=cut
2883
2884our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2885
2886sub cf::client::send_big_packet {
2887 my ($self, $pkt) = @_;
2888
2889 # try lzf for large packets
2890 $pkt = "lzf " . Compress::LZF::compress $pkt
2891 if 1024 <= length $pkt and $self->{can_lzf};
2892
2893 # split very large packets
2894 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2895 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2896 $pkt = "frag";
2897 }
2898
2899 $self->send_packet ($pkt);
2900}
2901
2727=item $client->send_msg ($channel, $msg, $color, [extra...]) 2902=item $client->send_msg ($channel, $msg, $color, [extra...])
2728 2903
2729Send a drawinfo or msg packet to the client, formatting the msg for the 2904Send a drawinfo or msg packet to the client, formatting the msg for the
2730client if neccessary. C<$type> should be a string identifying the type of 2905client if neccessary. C<$type> should be a string identifying the type of
2731the message, with C<log> being the default. If C<$color> is negative, suppress 2906the message, with C<log> being the default. If C<$color> is negative, suppress
… …
2733 2908
2734=cut 2909=cut
2735 2910
2736# non-persistent channels (usually the info channel) 2911# non-persistent channels (usually the info channel)
2737our %CHANNEL = ( 2912our %CHANNEL = (
2913 "c/motd" => {
2914 id => "infobox",
2915 title => "MOTD",
2916 reply => undef,
2917 tooltip => "The message of the day",
2918 },
2738 "c/identify" => { 2919 "c/identify" => {
2739 id => "infobox", 2920 id => "infobox",
2740 title => "Identify", 2921 title => "Identify",
2741 reply => undef, 2922 reply => undef,
2742 tooltip => "Items recently identified", 2923 tooltip => "Items recently identified",
… …
2744 "c/examine" => { 2925 "c/examine" => {
2745 id => "infobox", 2926 id => "infobox",
2746 title => "Examine", 2927 title => "Examine",
2747 reply => undef, 2928 reply => undef,
2748 tooltip => "Signs and other items you examined", 2929 tooltip => "Signs and other items you examined",
2930 },
2931 "c/shopinfo" => {
2932 id => "infobox",
2933 title => "Shop Info",
2934 reply => undef,
2935 tooltip => "What your bargaining skill tells you about the shop",
2749 }, 2936 },
2750 "c/book" => { 2937 "c/book" => {
2751 id => "infobox", 2938 id => "infobox",
2752 title => "Book", 2939 title => "Book",
2753 reply => undef, 2940 reply => undef,
… …
2769 id => "infobox", 2956 id => "infobox",
2770 title => "Body Parts", 2957 title => "Body Parts",
2771 reply => undef, 2958 reply => undef,
2772 tooltip => "Shows which body parts you posess and are available", 2959 tooltip => "Shows which body parts you posess and are available",
2773 }, 2960 },
2961 "c/statistics" => {
2962 id => "infobox",
2963 title => "Statistics",
2964 reply => undef,
2965 tooltip => "Shows your primary statistics",
2966 },
2774 "c/skills" => { 2967 "c/skills" => {
2775 id => "infobox", 2968 id => "infobox",
2776 title => "Skills", 2969 title => "Skills",
2777 reply => undef, 2970 reply => undef,
2778 tooltip => "Shows your experience per skill and item power", 2971 tooltip => "Shows your experience per skill and item power",
2972 },
2973 "c/shopitems" => {
2974 id => "infobox",
2975 title => "Shop Items",
2976 reply => undef,
2977 tooltip => "Shows the items currently for sale in this shop",
2978 },
2979 "c/resistances" => {
2980 id => "infobox",
2981 title => "Resistances",
2982 reply => undef,
2983 tooltip => "Shows your resistances",
2984 },
2985 "c/pets" => {
2986 id => "infobox",
2987 title => "Pets",
2988 reply => undef,
2989 tooltip => "Shows information abotu your pets/a specific pet",
2990 },
2991 "c/perceiveself" => {
2992 id => "infobox",
2993 title => "Perceive Self",
2994 reply => undef,
2995 tooltip => "You gained detailed knowledge about yourself",
2779 }, 2996 },
2780 "c/uptime" => { 2997 "c/uptime" => {
2781 id => "infobox", 2998 id => "infobox",
2782 title => "Uptime", 2999 title => "Uptime",
2783 reply => undef, 3000 reply => undef,
… …
2839 my $pkt = "msg " 3056 my $pkt = "msg "
2840 . $self->{json_coder}->encode ( 3057 . $self->{json_coder}->encode (
2841 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3058 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2842 ); 3059 );
2843 3060
2844 # try lzf for large packets
2845 $pkt = "lzf " . Compress::LZF::compress $pkt
2846 if 1024 <= length $pkt and $self->{can_lzf};
2847
2848 # split very large packets
2849 if (8192 < length $pkt and $self->{can_lzf}) {
2850 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2851 $pkt = "frag";
2852 }
2853
2854 $self->send_packet ($pkt); 3061 $self->send_big_packet ($pkt);
2855} 3062}
2856 3063
2857=item $client->ext_msg ($type, @msg) 3064=item $client->ext_msg ($type, @msg)
2858 3065
2859Sends an ext event to the client. 3066Sends an ext event to the client.
… …
2862 3069
2863sub cf::client::ext_msg($$@) { 3070sub cf::client::ext_msg($$@) {
2864 my ($self, $type, @msg) = @_; 3071 my ($self, $type, @msg) = @_;
2865 3072
2866 if ($self->extcmd == 2) { 3073 if ($self->extcmd == 2) {
2867 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3074 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2868 } elsif ($self->extcmd == 1) { # TODO: remove 3075 } elsif ($self->extcmd == 1) { # TODO: remove
2869 push @msg, msgtype => "event_$type"; 3076 push @msg, msgtype => "event_$type";
2870 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3077 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2871 } 3078 }
2872} 3079}
2873 3080
2874=item $client->ext_reply ($msgid, @msg) 3081=item $client->ext_reply ($msgid, @msg)
2875 3082
… …
2879 3086
2880sub cf::client::ext_reply($$@) { 3087sub cf::client::ext_reply($$@) {
2881 my ($self, $id, @msg) = @_; 3088 my ($self, $id, @msg) = @_;
2882 3089
2883 if ($self->extcmd == 2) { 3090 if ($self->extcmd == 2) {
2884 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3091 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2885 } elsif ($self->extcmd == 1) { 3092 } elsif ($self->extcmd == 1) {
2886 #TODO: version 1, remove 3093 #TODO: version 1, remove
2887 unshift @msg, msgtype => "reply", msgid => $id; 3094 unshift @msg, msgtype => "reply", msgid => $id;
2888 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3095 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2889 } 3096 }
2890} 3097}
2891 3098
2892=item $success = $client->query ($flags, "text", \&cb) 3099=item $success = $client->query ($flags, "text", \&cb)
2893 3100
… …
2994 3201
2995 $coro 3202 $coro
2996} 3203}
2997 3204
2998cf::client->attach ( 3205cf::client->attach (
2999 on_destroy => sub { 3206 on_client_destroy => sub {
3000 my ($ns) = @_; 3207 my ($ns) = @_;
3001 3208
3002 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3209 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3003 }, 3210 },
3004); 3211);
… …
3020our $safe_hole = new Safe::Hole; 3227our $safe_hole = new Safe::Hole;
3021 3228
3022$SIG{FPE} = 'IGNORE'; 3229$SIG{FPE} = 'IGNORE';
3023 3230
3024$safe->permit_only (Opcode::opset qw( 3231$safe->permit_only (Opcode::opset qw(
3025 :base_core :base_mem :base_orig :base_math 3232 :base_core :base_mem :base_orig :base_math :base_loop
3026 grepstart grepwhile mapstart mapwhile 3233 grepstart grepwhile mapstart mapwhile
3027 sort time 3234 sort time
3028)); 3235));
3029 3236
3030# here we export the classes and methods available to script code 3237# here we export the classes and methods available to script code
… …
3034The following functions and methods are available within a safe environment: 3241The following functions and methods are available within a safe environment:
3035 3242
3036 cf::object 3243 cf::object
3037 contr pay_amount pay_player map x y force_find force_add destroy 3244 contr pay_amount pay_player map x y force_find force_add destroy
3038 insert remove name archname title slaying race decrease split 3245 insert remove name archname title slaying race decrease split
3246 value
3039 3247
3040 cf::object::player 3248 cf::object::player
3041 player 3249 player
3042 3250
3043 cf::player 3251 cf::player
… …
3049=cut 3257=cut
3050 3258
3051for ( 3259for (
3052 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3260 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3053 insert remove inv nrof name archname title slaying race 3261 insert remove inv nrof name archname title slaying race
3054 decrease split destroy change_exp)], 3262 decrease split destroy change_exp value msg lore send_msg)],
3055 ["cf::object::player" => qw(player)], 3263 ["cf::object::player" => qw(player)],
3056 ["cf::player" => qw(peaceful)], 3264 ["cf::player" => qw(peaceful send_msg)],
3057 ["cf::map" => qw(trigger)], 3265 ["cf::map" => qw(trigger)],
3058) { 3266) {
3059 no strict 'refs'; 3267 no strict 'refs';
3060 my ($pkg, @funs) = @$_; 3268 my ($pkg, @funs) = @$_;
3061 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3269 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
3079 3287
3080 my $qcode = $code; 3288 my $qcode = $code;
3081 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3289 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3082 $qcode =~ s/\n/\\n/g; 3290 $qcode =~ s/\n/\\n/g;
3083 3291
3292 %vars = (_dummy => 0) unless %vars;
3293
3294 my @res;
3084 local $_; 3295 local $_;
3085 local @safe::cf::_safe_eval_args = values %vars;
3086 3296
3087 my $eval = 3297 my $eval =
3088 "do {\n" 3298 "do {\n"
3089 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3299 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3090 . "#line 0 \"{$qcode}\"\n" 3300 . "#line 0 \"{$qcode}\"\n"
3091 . $code 3301 . $code
3092 . "\n}" 3302 . "\n}"
3093 ; 3303 ;
3094 3304
3305 if ($CFG{safe_eval}) {
3095 sub_generation_inc; 3306 sub_generation_inc;
3307 local @safe::cf::_safe_eval_args = values %vars;
3096 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3308 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3097 sub_generation_inc; 3309 sub_generation_inc;
3310 } else {
3311 local @cf::_safe_eval_args = values %vars;
3312 @res = wantarray ? eval eval : scalar eval $eval;
3313 }
3098 3314
3099 if ($@) { 3315 if ($@) {
3100 warn "$@"; 3316 warn "$@";
3101 warn "while executing safe code '$code'\n"; 3317 warn "while executing safe code '$code'\n";
3102 warn "with arguments " . (join " ", %vars) . "\n"; 3318 warn "with arguments " . (join " ", %vars) . "\n";
… …
3121=cut 3337=cut
3122 3338
3123sub register_script_function { 3339sub register_script_function {
3124 my ($fun, $cb) = @_; 3340 my ($fun, $cb) = @_;
3125 3341
3126 no strict 'refs'; 3342 $fun = "safe::$fun" if $CFG{safe_eval};
3127 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3343 *$fun = $safe_hole->wrap ($cb);
3128} 3344}
3129 3345
3130=back 3346=back
3131 3347
3132=cut 3348=cut
… …
3153 3369
3154 $facedata->{version} == 2 3370 $facedata->{version} == 2
3155 or cf::cleanup "$path: version mismatch, cannot proceed."; 3371 or cf::cleanup "$path: version mismatch, cannot proceed.";
3156 3372
3157 # patch in the exptable 3373 # patch in the exptable
3374 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3158 $facedata->{resource}{"res/exp_table"} = { 3375 $facedata->{resource}{"res/exp_table"} = {
3159 type => FT_RSRC, 3376 type => FT_RSRC,
3160 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3377 data => $exp_table,
3378 hash => (Digest::MD5::md5 $exp_table),
3161 }; 3379 };
3162 cf::cede_to_tick; 3380 cf::cede_to_tick;
3163 3381
3164 { 3382 {
3165 my $faces = $facedata->{faceinfo}; 3383 my $faces = $facedata->{faceinfo};
… …
3167 while (my ($face, $info) = each %$faces) { 3385 while (my ($face, $info) = each %$faces) {
3168 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3386 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3169 3387
3170 cf::face::set_visibility $idx, $info->{visibility}; 3388 cf::face::set_visibility $idx, $info->{visibility};
3171 cf::face::set_magicmap $idx, $info->{magicmap}; 3389 cf::face::set_magicmap $idx, $info->{magicmap};
3172 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3390 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3173 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3391 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3174 3392
3175 cf::cede_to_tick; 3393 cf::cede_to_tick;
3176 } 3394 }
3177 3395
3178 while (my ($face, $info) = each %$faces) { 3396 while (my ($face, $info) = each %$faces) {
… …
3202 3420
3203 cf::anim::invalidate_all; # d'oh 3421 cf::anim::invalidate_all; # d'oh
3204 } 3422 }
3205 3423
3206 { 3424 {
3207 # TODO: for gcfclient pleasure, we should give resources
3208 # that gcfclient doesn't grok a >10000 face index.
3209 my $res = $facedata->{resource}; 3425 my $res = $facedata->{resource};
3210 3426
3211 while (my ($name, $info) = each %$res) { 3427 while (my ($name, $info) = each %$res) {
3212 if (defined $info->{type}) { 3428 if (defined $info->{type}) {
3213 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3429 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3214 my $data;
3215 3430
3216 if ($info->{type} & 1) { 3431 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3217 # prepend meta info
3218
3219 my $meta = $enc->encode ({
3220 name => $name,
3221 %{ $info->{meta} || {} },
3222 });
3223
3224 $data = pack "(w/a*)*", $meta, $info->{data};
3225 } else {
3226 $data = $info->{data};
3227 }
3228
3229 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3230 cf::face::set_type $idx, $info->{type}; 3432 cf::face::set_type $idx, $info->{type};
3231 } else { 3433 } else {
3232 $RESOURCE{$name} = $info; 3434 $RESOURCE{$name} = $info;
3233 } 3435 }
3234 3436
… …
3318 3520
3319 warn "finished reloading resource files\n"; 3521 warn "finished reloading resource files\n";
3320} 3522}
3321 3523
3322sub reload_config { 3524sub reload_config {
3525 warn "reloading config file...\n";
3526
3323 open my $fh, "<:utf8", "$CONFDIR/config" 3527 open my $fh, "<:utf8", "$CONFDIR/config"
3324 or return; 3528 or return;
3325 3529
3326 local $/; 3530 local $/;
3327 *CFG = YAML::Load <$fh>; 3531 *CFG = YAML::XS::Load scalar <$fh>;
3328 3532
3329 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3533 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3330 3534
3331 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3535 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3332 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3536 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3333 3537
3334 if (exists $CFG{mlockall}) { 3538 if (exists $CFG{mlockall}) {
… …
3336 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3540 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3337 and die "WARNING: m(un)lockall failed: $!\n"; 3541 and die "WARNING: m(un)lockall failed: $!\n";
3338 }; 3542 };
3339 warn $@ if $@; 3543 warn $@ if $@;
3340 } 3544 }
3545
3546 warn "finished reloading resource files\n";
3341} 3547}
3342 3548
3343sub pidfile() { 3549sub pidfile() {
3344 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3550 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3345 or die "$PIDFILE: $!"; 3551 or die "$PIDFILE: $!";
… …
3357 3563
3358 seek $fh, 0, 0; 3564 seek $fh, 0, 0;
3359 print $fh $$; 3565 print $fh $$;
3360} 3566}
3361 3567
3568sub main_loop {
3569 warn "EV::loop starting\n";
3570 if (1) {
3571 EV::loop;
3572 }
3573 warn "EV::loop returned\n";
3574 goto &main_loop unless $REALLY_UNLOOP;
3575}
3576
3362sub main { 3577sub main {
3363 cf::init_globals; # initialise logging 3578 cf::init_globals; # initialise logging
3364 3579
3365 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3580 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3366 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3581 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3367 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3582 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3368 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3583 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3369
3370 cf::init_experience;
3371 cf::init_anim;
3372 cf::init_attackmess;
3373 cf::init_dynamic;
3374 3584
3375 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3585 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3376 3586
3377 # we must not ever block the main coroutine 3587 # we must not ever block the main coroutine
3378 local $Coro::idle = sub { 3588 local $Coro::idle = sub {
… …
3384 }; 3594 };
3385 3595
3386 evthread_start IO::AIO::poll_fileno; 3596 evthread_start IO::AIO::poll_fileno;
3387 3597
3388 cf::sync_job { 3598 cf::sync_job {
3599 cf::init_experience;
3600 cf::init_anim;
3601 cf::init_attackmess;
3602 cf::init_dynamic;
3603
3604 cf::load_settings;
3605 cf::load_materials;
3606
3389 reload_resources; 3607 reload_resources;
3390 reload_config; 3608 reload_config;
3391 db_init; 3609 db_init;
3392 3610
3393 cf::load_settings;
3394 cf::load_materials;
3395 cf::init_uuid; 3611 cf::init_uuid;
3396 cf::init_signals; 3612 cf::init_signals;
3397 cf::init_commands;
3398 cf::init_skills; 3613 cf::init_skills;
3399 3614
3400 cf::init_beforeplay; 3615 cf::init_beforeplay;
3401 3616
3402 atomic; 3617 atomic;
… …
3404 load_extensions; 3619 load_extensions;
3405 3620
3406 utime time, time, $RUNTIMEFILE; 3621 utime time, time, $RUNTIMEFILE;
3407 3622
3408 # no (long-running) fork's whatsoever before this point(!) 3623 # no (long-running) fork's whatsoever before this point(!)
3624 use POSIX ();
3409 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3625 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3410 3626
3411 (pop @POST_INIT)->(0) while @POST_INIT; 3627 (pop @POST_INIT)->(0) while @POST_INIT;
3412 }; 3628 };
3413 3629
3414 EV::loop; 3630 cf::object::thawer::errors_are_fatal 0;
3631 warn "parse errors in files are no longer fatal from this point on.\n";
3632
3633 main_loop;
3415} 3634}
3416 3635
3417############################################################################# 3636#############################################################################
3418# initialisation and cleanup 3637# initialisation and cleanup
3419 3638
3420# install some emergency cleanup handlers 3639# install some emergency cleanup handlers
3421BEGIN { 3640BEGIN {
3422 our %SIGWATCHER = (); 3641 our %SIGWATCHER = ();
3423 for my $signal (qw(INT HUP TERM)) { 3642 for my $signal (qw(INT HUP TERM)) {
3424 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3643 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3425 cf::cleanup "SIG$signal"; 3644 cf::cleanup "SIG$signal";
3426 }; 3645 };
3427 } 3646 }
3428} 3647}
3429 3648
3430sub write_runtime_sync { 3649sub write_runtime_sync {
3650 my $t0 = AE::time;
3651
3431 # first touch the runtime file to show we are still running: 3652 # first touch the runtime file to show we are still running:
3432 # the fsync below can take a very very long time. 3653 # the fsync below can take a very very long time.
3433 3654
3434 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3655 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3435 3656
3436 my $guard = cf::lock_acquire "write_runtime"; 3657 my $guard = cf::lock_acquire "write_runtime";
3437 3658
3438 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3659 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3439 or return; 3660 or return;
3440 3661
3441 my $value = $cf::RUNTIME + 90 + 10; 3662 my $value = $cf::RUNTIME + 90 + 10;
3442 # 10 is the runtime save interval, for a monotonic clock 3663 # 10 is the runtime save interval, for a monotonic clock
3443 # 60 allows for the watchdog to kill the server. 3664 # 60 allows for the watchdog to kill the server.
… …
3456 or return; 3677 or return;
3457 3678
3458 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3679 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3459 and return; 3680 and return;
3460 3681
3461 warn "runtime file written.\n"; 3682 warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3462 3683
3463 1 3684 1
3464} 3685}
3465 3686
3466our $uuid_lock; 3687our $uuid_lock;
… …
3592 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3813 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3593 for my $name (keys %$leaf_symtab) { 3814 for my $name (keys %$leaf_symtab) {
3594 _gv_clear *{"$pkg$name"}; 3815 _gv_clear *{"$pkg$name"};
3595# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3816# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3596 } 3817 }
3597 warn "cleared package $pkg\n";#d#
3598} 3818}
3599 3819
3600sub do_reload_perl() { 3820sub do_reload_perl() {
3601 # can/must only be called in main 3821 # can/must only be called in main
3602 if ($Coro::current != $Coro::main) { 3822 if (in_main) {
3603 warn "can only reload from main coroutine"; 3823 warn "can only reload from main coroutine";
3604 return; 3824 return;
3605 } 3825 }
3606 3826
3607 return if $RELOAD++; 3827 return if $RELOAD++;
3608 3828
3609 my $t1 = EV::time; 3829 my $t1 = AE::time;
3610 3830
3611 while ($RELOAD) { 3831 while ($RELOAD) {
3612 warn "reloading..."; 3832 warn "reloading...";
3613 3833
3614 warn "entering sync_job"; 3834 warn "entering sync_job";
… …
3675 clear_package "safe::$_" 3895 clear_package "safe::$_"
3676 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3896 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3677 3897
3678 warn "unloading cf.pm \"a bit\""; 3898 warn "unloading cf.pm \"a bit\"";
3679 delete $INC{"cf.pm"}; 3899 delete $INC{"cf.pm"};
3680 delete $INC{"cf/pod.pm"}; 3900 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3681 3901
3682 # don't, removes xs symbols, too, 3902 # don't, removes xs symbols, too,
3683 # and global variables created in xs 3903 # and global variables created in xs
3684 #clear_package __PACKAGE__; 3904 #clear_package __PACKAGE__;
3685 3905
3686 warn "unload completed, starting to reload now"; 3906 warn "unload completed, starting to reload now";
3687 3907
3688 warn "reloading cf.pm"; 3908 warn "reloading cf.pm";
3689 require cf; 3909 require cf;
3690 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3910 cf::_connect_to_perl_1;
3691 3911
3692 warn "loading config and database again"; 3912 warn "loading config and database again";
3693 cf::reload_config; 3913 cf::reload_config;
3694 3914
3695 warn "loading extensions"; 3915 warn "loading extensions";
… …
3717 3937
3718 warn "reloaded"; 3938 warn "reloaded";
3719 --$RELOAD; 3939 --$RELOAD;
3720 } 3940 }
3721 3941
3722 $t1 = EV::time - $t1; 3942 $t1 = AE::time - $t1;
3723 warn "reload completed in ${t1}s\n"; 3943 warn "reload completed in ${t1}s\n";
3724}; 3944};
3725 3945
3726our $RELOAD_WATCHER; # used only during reload 3946our $RELOAD_WATCHER; # used only during reload
3727 3947
… …
3730 # coro crashes during coro_state_free->destroy here. 3950 # coro crashes during coro_state_free->destroy here.
3731 3951
3732 $RELOAD_WATCHER ||= cf::async { 3952 $RELOAD_WATCHER ||= cf::async {
3733 Coro::AIO::aio_wait cache_extensions; 3953 Coro::AIO::aio_wait cache_extensions;
3734 3954
3735 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 3955 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3736 do_reload_perl; 3956 do_reload_perl;
3737 undef $RELOAD_WATCHER; 3957 undef $RELOAD_WATCHER;
3738 }; 3958 };
3739 }; 3959 };
3740} 3960}
… …
3757 3977
3758our @WAIT_FOR_TICK; 3978our @WAIT_FOR_TICK;
3759our @WAIT_FOR_TICK_BEGIN; 3979our @WAIT_FOR_TICK_BEGIN;
3760 3980
3761sub wait_for_tick { 3981sub wait_for_tick {
3762 return if tick_inhibit || $Coro::current == $Coro::main; 3982 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3763 3983
3764 my $signal = new Coro::Signal; 3984 my $signal = new Coro::Signal;
3765 push @WAIT_FOR_TICK, $signal; 3985 push @WAIT_FOR_TICK, $signal;
3766 $signal->wait; 3986 $signal->wait;
3767} 3987}
3768 3988
3769sub wait_for_tick_begin { 3989sub wait_for_tick_begin {
3770 return if tick_inhibit || $Coro::current == $Coro::main; 3990 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3771 3991
3772 my $signal = new Coro::Signal; 3992 my $signal = new Coro::Signal;
3773 push @WAIT_FOR_TICK_BEGIN, $signal; 3993 push @WAIT_FOR_TICK_BEGIN, $signal;
3774 $signal->wait; 3994 $signal->wait;
3775} 3995}
… …
3780 unless ++$bug_warning > 10; 4000 unless ++$bug_warning > 10;
3781 return; 4001 return;
3782 } 4002 }
3783 4003
3784 cf::server_tick; # one server iteration 4004 cf::server_tick; # one server iteration
4005
4006 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3785 4007
3786 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4008 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3787 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4009 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3788 Coro::async_pool { 4010 Coro::async_pool {
3789 $Coro::current->{desc} = "runtime saver"; 4011 $Coro::current->{desc} = "runtime saver";
… …
3812} 4034}
3813 4035
3814{ 4036{
3815 # configure BDB 4037 # configure BDB
3816 4038
3817 BDB::min_parallel 8; 4039 BDB::min_parallel 16;
3818 BDB::max_poll_reqs $TICK * 0.1; 4040 BDB::max_poll_reqs $TICK * 0.1;
3819 $AnyEvent::BDB::WATCHER->priority (1); 4041 $AnyEvent::BDB::WATCHER->priority (1);
3820 4042
3821 unless ($DB_ENV) { 4043 unless ($DB_ENV) {
3822 $DB_ENV = BDB::db_env_create; 4044 $DB_ENV = BDB::db_env_create;
… …
3902 LOG llevInfo, "[ABT] [suppressed]\n"; 4124 LOG llevInfo, "[ABT] [suppressed]\n";
3903 } 4125 }
3904} 4126}
3905 4127
3906# load additional modules 4128# load additional modules
3907use cf::pod; 4129require "cf/$_.pm" for @EXTRA_MODULES;
4130cf::_connect_to_perl_2;
3908 4131
3909END { cf::emergency_save } 4132END { cf::emergency_save }
3910 4133
39111 41341
3912 4135

Diff Legend

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