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.479 by root, Thu Oct 8 05:04:27 2009 UTC vs.
Revision 1.522 by root, Sat Apr 17 02:22:14 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
… …
107our $PIDFILE = "$LOCALDIR/pid"; 108our $PIDFILE = "$LOCALDIR/pid";
108our $RUNTIMEFILE = "$LOCALDIR/runtime"; 109our $RUNTIMEFILE = "$LOCALDIR/runtime";
109 110
110our %RESOURCE; 111our %RESOURCE;
111 112
113our $OUTPUT_RATE_MIN = 4000;
114our $OUTPUT_RATE_MAX = 100000;
115
112our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 116our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
113our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 117our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
114our $NEXT_TICK; 118our $NEXT_TICK;
115our $USE_FSYNC = 1; # use fsync to write maps - default on 119our $USE_FSYNC = 1; # use fsync to write maps - default on
116 120
117our $BDB_DEADLOCK_WATCHER; 121our $BDB_DEADLOCK_WATCHER;
118our $BDB_CHECKPOINT_WATCHER; 122our $BDB_CHECKPOINT_WATCHER;
119our $BDB_TRICKLE_WATCHER; 123our $BDB_TRICKLE_WATCHER;
120our $DB_ENV; 124our $DB_ENV;
121 125
122our @EXTRA_MODULES = qw(pod mapscript); 126our @EXTRA_MODULES = qw(pod match mapscript);
123 127
124our %CFG; 128our %CFG;
125 129
126our $UPTIME; $UPTIME ||= time; 130our $UPTIME; $UPTIME ||= time;
127our $RUNTIME; 131our $RUNTIME;
… …
161 165
162our $EMERGENCY_POSITION; 166our $EMERGENCY_POSITION;
163 167
164sub cf::map::normalise; 168sub cf::map::normalise;
165 169
170sub in_main() {
171 $Coro::current == $Coro::main
172}
173
166############################################################################# 174#############################################################################
167 175
168%REFLECT = (); 176%REFLECT = ();
169for (@REFLECT) { 177for (@REFLECT) {
170 my $reflect = JSON::XS::decode_json $_; 178 my $reflect = JSON::XS::decode_json $_;
171 $REFLECT{$reflect->{class}} = $reflect; 179 $REFLECT{$reflect->{class}} = $reflect;
172} 180}
173 181
182# this is decidedly evil
183$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
184
174############################################################################# 185#############################################################################
175 186
176=head2 GLOBAL VARIABLES 187=head2 GLOBAL VARIABLES
177 188
178=over 4 189=over 4
… …
224returns directly I<after> the tick processing (and consequently, can only wake one process 235returns directly I<after> the tick processing (and consequently, can only wake one process
225per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 236per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
226 237
227=item @cf::INVOKE_RESULTS 238=item @cf::INVOKE_RESULTS
228 239
229This array contains the results of the last C<invoke ()> call. When 240This array contains the results of the last C<invoke ()> call. When
230C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 241C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
231that call. 242that call.
232 243
233=item %cf::REFLECT 244=item %cf::REFLECT
234 245
235Contains, for each (C++) class name, a hash reference with information 246Contains, for each (C++) class name, a hash reference with information
236about object members (methods, scalars and arrays) and other metadata, 247about object members (methods, scalars, arrays and flags) and other
237which is useful for introspection. 248metadata, which is useful for introspection.
238 249
239=back 250=back
240 251
241=cut 252=cut
242 253
… …
254$Coro::State::DIEHOOK = sub { 265$Coro::State::DIEHOOK = sub {
255 return unless $^S eq 0; # "eq", not "==" 266 return unless $^S eq 0; # "eq", not "=="
256 267
257 warn Carp::longmess $_[0]; 268 warn Carp::longmess $_[0];
258 269
259 if ($Coro::current == $Coro::main) {#d# 270 if (in_main) {#d#
260 warn "DIEHOOK called in main context, Coro bug?\n";#d# 271 warn "DIEHOOK called in main context, Coro bug?\n";#d#
261 return;#d# 272 return;#d#
262 }#d# 273 }#d#
263 274
264 # kill coroutine otherwise 275 # kill coroutine otherwise
… …
285)) { 296)) {
286 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 297 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
287} 298}
288 299
289$EV::DIED = sub { 300$EV::DIED = sub {
290 warn "error in event callback: @_"; 301 Carp::cluck "error in event callback: @_";
291}; 302};
292 303
293############################################################################# 304#############################################################################
294 305
295=head2 UTILITY FUNCTIONS 306=head2 UTILITY FUNCTIONS
… …
392} 403}
393 404
394=item cf::periodic $interval, $cb 405=item cf::periodic $interval, $cb
395 406
396Like EV::periodic, but randomly selects a starting point so that the actions 407Like EV::periodic, but randomly selects a starting point so that the actions
397get spread over timer. 408get spread over time.
398 409
399=cut 410=cut
400 411
401sub periodic($$) { 412sub periodic($$) {
402 my ($interval, $cb) = @_; 413 my ($interval, $cb) = @_;
… …
419 430
420=cut 431=cut
421 432
422our @SLOT_QUEUE; 433our @SLOT_QUEUE;
423our $SLOT_QUEUE; 434our $SLOT_QUEUE;
435our $SLOT_DECAY = 0.9;
424 436
425$SLOT_QUEUE->cancel if $SLOT_QUEUE; 437$SLOT_QUEUE->cancel if $SLOT_QUEUE;
426$SLOT_QUEUE = Coro::async { 438$SLOT_QUEUE = Coro::async {
427 $Coro::current->desc ("timeslot manager"); 439 $Coro::current->desc ("timeslot manager");
428 440
429 my $signal = new Coro::Signal; 441 my $signal = new Coro::Signal;
442 my $busy;
430 443
431 while () { 444 while () {
432 next_job: 445 next_job:
446
433 my $avail = cf::till_tick; 447 my $avail = cf::till_tick;
434 if ($avail > 0.01) { 448
435 for (0 .. $#SLOT_QUEUE) { 449 for (0 .. $#SLOT_QUEUE) {
436 if ($SLOT_QUEUE[$_][0] < $avail) { 450 if ($SLOT_QUEUE[$_][0] <= $avail) {
451 $busy = 0;
437 my $job = splice @SLOT_QUEUE, $_, 1, (); 452 my $job = splice @SLOT_QUEUE, $_, 1, ();
438 $job->[2]->send; 453 $job->[2]->send;
439 Coro::cede; 454 Coro::cede;
440 goto next_job; 455 goto next_job;
441 } 456 } else {
457 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
442 } 458 }
443 } 459 }
444 460
445 if (@SLOT_QUEUE) { 461 if (@SLOT_QUEUE) {
446 # we do not use wait_for_tick() as it returns immediately when tick is inactive 462 # we do not use wait_for_tick() as it returns immediately when tick is inactive
447 push @cf::WAIT_FOR_TICK, $signal; 463 push @cf::WAIT_FOR_TICK, $signal;
448 $signal->wait; 464 $signal->wait;
449 } else { 465 } else {
466 $busy = 0;
450 Coro::schedule; 467 Coro::schedule;
451 } 468 }
452 } 469 }
453}; 470};
454 471
455sub get_slot($;$$) { 472sub get_slot($;$$) {
456 return if tick_inhibit || $Coro::current == $Coro::main; 473 return if tick_inhibit || $Coro::current == $Coro::main;
457 474
458 my ($time, $pri, $name) = @_; 475 my ($time, $pri, $name) = @_;
459 476
460 $time = $TICK * .6 if $time > $TICK * .6; 477 $time = clamp $time, 0.01, $TICK * .6;
478
461 my $sig = new Coro::Signal; 479 my $sig = new Coro::Signal;
462 480
463 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 481 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
464 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 482 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
465 $SLOT_QUEUE->ready; 483 $SLOT_QUEUE->ready;
… …
492 510
493sub sync_job(&) { 511sub sync_job(&) {
494 my ($job) = @_; 512 my ($job) = @_;
495 513
496 if ($Coro::current == $Coro::main) { 514 if ($Coro::current == $Coro::main) {
497 my $time = EV::time; 515 my $time = AE::time;
498 516
499 # this is the main coro, too bad, we have to block 517 # this is the main coro, too bad, we have to block
500 # till the operation succeeds, freezing the server :/ 518 # till the operation succeeds, freezing the server :/
501 519
502 LOG llevError, Carp::longmess "sync job";#d# 520 LOG llevError, Carp::longmess "sync job";#d#
… …
519 } else { 537 } else {
520 EV::loop EV::LOOP_ONESHOT; 538 EV::loop EV::LOOP_ONESHOT;
521 } 539 }
522 } 540 }
523 541
524 my $time = EV::time - $time; 542 my $time = AE::time - $time;
525 543
526 $TICK_START += $time; # do not account sync jobs to server load 544 $TICK_START += $time; # do not account sync jobs to server load
527 545
528 wantarray ? @res : $res[0] 546 wantarray ? @res : $res[0]
529 } else { 547 } else {
… …
573 reset_signals; 591 reset_signals;
574 &$cb 592 &$cb
575 }, @args; 593 }, @args;
576 594
577 wantarray ? @res : $res[-1] 595 wantarray ? @res : $res[-1]
596}
597
598sub objinfo {
599 (
600 "counter value" => cf::object::object_count,
601 "objects created" => cf::object::create_count,
602 "objects destroyed" => cf::object::destroy_count,
603 "freelist size" => cf::object::free_count,
604 "allocated objects" => cf::object::objects_size,
605 "active objects" => cf::object::actives_size,
606 )
578} 607}
579 608
580=item $coin = coin_from_name $name 609=item $coin = coin_from_name $name
581 610
582=cut 611=cut
… …
1299} 1328}
1300 1329
1301use File::Glob (); 1330use File::Glob ();
1302 1331
1303cf::player->attach ( 1332cf::player->attach (
1304 on_command => sub { 1333 on_unknown_command => sub {
1305 my ($pl, $name, $params) = @_; 1334 my ($pl, $name, $params) = @_;
1306 1335
1307 my $cb = $COMMAND{$name} 1336 my $cb = $COMMAND{$name}
1308 or return; 1337 or return;
1309 1338
… …
1388 . "\n};\n1"; 1417 . "\n};\n1";
1389 1418
1390 $todo{$base} = \%ext; 1419 $todo{$base} = \%ext;
1391 } 1420 }
1392 1421
1422 my $pass = 0;
1393 my %done; 1423 my %done;
1394 while (%todo) { 1424 while (%todo) {
1395 my $progress; 1425 my $progress;
1396 1426
1427 ++$pass;
1428
1429 ext:
1397 while (my ($k, $v) = each %todo) { 1430 while (my ($k, $v) = each %todo) {
1398 for (split /,\s*/, $v->{meta}{depends}) { 1431 for (split /,\s*/, $v->{meta}{depends}) {
1399 goto skip 1432 next ext
1400 unless exists $done{$_}; 1433 unless exists $done{$_};
1401 } 1434 }
1402 1435
1403 warn "... loading '$k' into '$v->{pkg}'\n"; 1436 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1404 1437
1405 unless (eval $v->{source}) { 1438 my $active = eval $v->{source};
1439
1440 if (length $@) {
1406 my $msg = $@ ? "$v->{path}: $@\n" 1441 warn "$v->{path}: $@\n";
1407 : "$v->{base}: extension inactive.\n";
1408 1442
1409 if (exists $v->{meta}{mandatory}) {
1410 warn $msg;
1411 cf::cleanup "mandatory extension failed to load, exiting."; 1443 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1412 } 1444 if exists $v->{meta}{mandatory};
1413 1445
1414 warn $msg; 1446 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1447 delete $todo{$k};
1448 } else {
1449 $done{$k} = delete $todo{$k};
1450 push @EXTS, $v->{pkg};
1451 $progress = 1;
1452
1453 warn "$v->{base}: extension inactive.\n"
1454 unless $active;
1415 } 1455 }
1416
1417 $done{$k} = delete $todo{$k};
1418 push @EXTS, $v->{pkg};
1419 $progress = 1;
1420 } 1456 }
1421 1457
1422 skip: 1458 unless ($progress) {
1423 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1459 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1424 unless $progress; 1460
1461 while (my ($k, $v) = each %todo) {
1462 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1463 if exists $v->{meta}{mandatory};
1464 }
1465 }
1425 } 1466 }
1426 }; 1467 };
1427} 1468}
1428 1469
1429############################################################################# 1470#############################################################################
… …
1513 $cf::PLAYER{$login} = $pl 1554 $cf::PLAYER{$login} = $pl
1514 } 1555 }
1515 } 1556 }
1516} 1557}
1517 1558
1559cf::player->attach (
1560 on_load => sub {
1561 my ($pl, $path) = @_;
1562
1563 # restore slots saved in save, below
1564 my $slots = delete $pl->{_slots};
1565
1566 $pl->ob->current_weapon ($slots->[0]);
1567 $pl->combat_ob ($slots->[1]);
1568 $pl->ranged_ob ($slots->[2]);
1569 },
1570);
1571
1518sub save($) { 1572sub save($) {
1519 my ($pl) = @_; 1573 my ($pl) = @_;
1520 1574
1521 return if $pl->{deny_save}; 1575 return if $pl->{deny_save};
1522 1576
… …
1527 1581
1528 aio_mkdir playerdir $pl, 0770; 1582 aio_mkdir playerdir $pl, 0770;
1529 $pl->{last_save} = $cf::RUNTIME; 1583 $pl->{last_save} = $cf::RUNTIME;
1530 1584
1531 cf::get_slot 0.01; 1585 cf::get_slot 0.01;
1586
1587 # save slots, to be restored later
1588 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1532 1589
1533 $pl->save_pl ($path); 1590 $pl->save_pl ($path);
1534 cf::cede_to_tick; 1591 cf::cede_to_tick;
1535} 1592}
1536 1593
… …
1749 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1806 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1750 1807
1751 # mit "rum" bekleckern, nicht 1808 # mit "rum" bekleckern, nicht
1752 $self->_create_random_map ( 1809 $self->_create_random_map (
1753 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1810 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1754 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1811 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1755 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1812 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1756 $rmp->{exit_on_final_map}, 1813 $rmp->{exit_on_final_map},
1757 $rmp->{xsize}, $rmp->{ysize}, 1814 $rmp->{xsize}, $rmp->{ysize},
1758 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1815 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1759 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1816 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
2005 2062
2006 $cf::MAP{$path} = $map 2063 $cf::MAP{$path} = $map
2007 } 2064 }
2008} 2065}
2009 2066
2010sub pre_load { } 2067sub pre_load { }
2011sub post_load { } 2068#sub post_load { } # XS
2012 2069
2013sub load { 2070sub load {
2014 my ($self) = @_; 2071 my ($self) = @_;
2015 2072
2016 local $self->{deny_reset} = 1; # loading can take a long time 2073 local $self->{deny_reset} = 1; # loading can take a long time
… …
2073 } 2130 }
2074 2131
2075 $self->post_load; 2132 $self->post_load;
2076} 2133}
2077 2134
2135# customize the map for a given player, i.e.
2136# return the _real_ map. used by e.g. per-player
2137# maps to change the path to ~playername/mappath
2078sub customise_for { 2138sub customise_for {
2079 my ($self, $ob) = @_; 2139 my ($self, $ob) = @_;
2080 2140
2081 return find "~" . $ob->name . "/" . $self->{path} 2141 return find "~" . $ob->name . "/" . $self->{path}
2082 if $self->per_player; 2142 if $self->per_player;
… …
2159 $MAP_PREFETCHER->prio (6); 2219 $MAP_PREFETCHER->prio (6);
2160 2220
2161 () 2221 ()
2162} 2222}
2163 2223
2224# common code, used by both ->save and ->swapout
2164sub save { 2225sub _save {
2165 my ($self) = @_; 2226 my ($self) = @_;
2166
2167 my $lock = cf::lock_acquire "map_data:$self->{path}";
2168 2227
2169 $self->{last_save} = $cf::RUNTIME; 2228 $self->{last_save} = $cf::RUNTIME;
2170 2229
2171 return unless $self->dirty; 2230 return unless $self->dirty;
2172 2231
… …
2192 } else { 2251 } else {
2193 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2252 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2194 } 2253 }
2195} 2254}
2196 2255
2256sub save {
2257 my ($self) = @_;
2258
2259 my $lock = cf::lock_acquire "map_data:$self->{path}";
2260
2261 $self->_save;
2262}
2263
2197sub swap_out { 2264sub swap_out {
2198 my ($self) = @_; 2265 my ($self) = @_;
2199 2266
2200 # save first because save cedes
2201 $self->save;
2202
2203 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2267 my $lock = cf::lock_acquire "map_data:$self->{path}";
2204 2268
2205 return if $self->players;
2206 return if $self->in_memory != cf::MAP_ACTIVE; 2269 return if $self->in_memory != cf::MAP_ACTIVE;
2207 return if $self->{deny_save}; 2270 return if $self->{deny_save};
2271 return if $self->players;
2208 2272
2209 $self->in_memory (cf::MAP_SWAPPED); 2273 # first deactivate the map and "unlink" it from the core
2210
2211 $self->deactivate; 2274 $self->deactivate;
2212 $_->clear_links_to ($self) for values %cf::MAP; 2275 $_->clear_links_to ($self) for values %cf::MAP;
2276 $self->in_memory (cf::MAP_SWAPPED);
2277
2278 # then atomically save
2279 $self->_save;
2280
2281 # then free the map
2213 $self->clear; 2282 $self->clear;
2214} 2283}
2215 2284
2216sub reset_at { 2285sub reset_at {
2217 my ($self) = @_; 2286 my ($self) = @_;
… …
2337 : normalise $_ 2406 : normalise $_
2338 } @{ aio_readdir $UNIQUEDIR or [] } 2407 } @{ aio_readdir $UNIQUEDIR or [] }
2339 ] 2408 ]
2340} 2409}
2341 2410
2411=item cf::map::static_maps
2412
2413Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2414file in the shared directory excluding F</styles> and F</editor>). May
2415block.
2416
2417=cut
2418
2419sub static_maps() {
2420 my @dirs = "";
2421 my @maps;
2422
2423 while (@dirs) {
2424 my $dir = shift @dirs;
2425
2426 next if $dir eq "/styles" || $dir eq "/editor";
2427
2428 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2429 or return;
2430
2431 for (@$files) {
2432 s/\.map$// or next;
2433 utf8::decode $_;
2434 push @maps, "$dir/$_";
2435 }
2436
2437 push @dirs, map "$dir/$_", @$dirs;
2438 }
2439
2440 \@maps
2441}
2442
2342=back 2443=back
2343 2444
2344=head3 cf::object 2445=head3 cf::object
2345 2446
2346=cut 2447=cut
… …
2514 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2615 return if UNIVERSAL::isa $self->map, "ext::map_link";
2515 2616
2516 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2617 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2517 if $self->map && $self->map->{path} ne "{link}"; 2618 if $self->map && $self->map->{path} ne "{link}";
2518 2619
2519 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2620 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2520} 2621}
2521 2622
2522sub cf::object::player::leave_link { 2623sub cf::object::player::leave_link {
2523 my ($self, $map, $x, $y) = @_; 2624 my ($self, $map, $x, $y) = @_;
2524 2625
… …
2541 ($x, $y) = (-1, -1) 2642 ($x, $y) = (-1, -1)
2542 unless (defined $x) && (defined $y); 2643 unless (defined $x) && (defined $y);
2543 2644
2544 # use -1 or undef as default coordinates, not 0, 0 2645 # use -1 or undef as default coordinates, not 0, 0
2545 ($x, $y) = ($map->enter_x, $map->enter_y) 2646 ($x, $y) = ($map->enter_x, $map->enter_y)
2546 if $x <=0 && $y <= 0; 2647 if $x <= 0 && $y <= 0;
2547 2648
2548 $map->load; 2649 $map->load;
2549 $map->load_neighbours; 2650 $map->load_neighbours;
2550 2651
2551 return unless $self->contr->active; 2652 return unless $self->contr->active;
… …
2750 2851
2751 utf8::encode $text; 2852 utf8::encode $text;
2752 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2853 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2753} 2854}
2754 2855
2856=item $client->send_big_packet ($pkt)
2857
2858Like C<send_packet>, but tries to compress large packets, and fragments
2859them as required.
2860
2861=cut
2862
2863our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2864
2865sub cf::client::send_big_packet {
2866 my ($self, $pkt) = @_;
2867
2868 # try lzf for large packets
2869 $pkt = "lzf " . Compress::LZF::compress $pkt
2870 if 1024 <= length $pkt and $self->{can_lzf};
2871
2872 # split very large packets
2873 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2874 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2875 $pkt = "frag";
2876 }
2877
2878 $self->send_packet ($pkt);
2879}
2880
2755=item $client->send_msg ($channel, $msg, $color, [extra...]) 2881=item $client->send_msg ($channel, $msg, $color, [extra...])
2756 2882
2757Send a drawinfo or msg packet to the client, formatting the msg for the 2883Send a drawinfo or msg packet to the client, formatting the msg for the
2758client if neccessary. C<$type> should be a string identifying the type of 2884client if neccessary. C<$type> should be a string identifying the type of
2759the message, with C<log> being the default. If C<$color> is negative, suppress 2885the message, with C<log> being the default. If C<$color> is negative, suppress
… …
2761 2887
2762=cut 2888=cut
2763 2889
2764# non-persistent channels (usually the info channel) 2890# non-persistent channels (usually the info channel)
2765our %CHANNEL = ( 2891our %CHANNEL = (
2892 "c/motd" => {
2893 id => "infobox",
2894 title => "MOTD",
2895 reply => undef,
2896 tooltip => "The message of the day",
2897 },
2766 "c/identify" => { 2898 "c/identify" => {
2767 id => "infobox", 2899 id => "infobox",
2768 title => "Identify", 2900 title => "Identify",
2769 reply => undef, 2901 reply => undef,
2770 tooltip => "Items recently identified", 2902 tooltip => "Items recently identified",
… …
2772 "c/examine" => { 2904 "c/examine" => {
2773 id => "infobox", 2905 id => "infobox",
2774 title => "Examine", 2906 title => "Examine",
2775 reply => undef, 2907 reply => undef,
2776 tooltip => "Signs and other items you examined", 2908 tooltip => "Signs and other items you examined",
2909 },
2910 "c/shopinfo" => {
2911 id => "infobox",
2912 title => "Shop Info",
2913 reply => undef,
2914 tooltip => "What your bargaining skill tells you about the shop",
2777 }, 2915 },
2778 "c/book" => { 2916 "c/book" => {
2779 id => "infobox", 2917 id => "infobox",
2780 title => "Book", 2918 title => "Book",
2781 reply => undef, 2919 reply => undef,
… …
2897 my $pkt = "msg " 3035 my $pkt = "msg "
2898 . $self->{json_coder}->encode ( 3036 . $self->{json_coder}->encode (
2899 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3037 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2900 ); 3038 );
2901 3039
2902 # try lzf for large packets
2903 $pkt = "lzf " . Compress::LZF::compress $pkt
2904 if 1024 <= length $pkt and $self->{can_lzf};
2905
2906 # split very large packets
2907 if (8192 < length $pkt and $self->{can_lzf}) {
2908 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2909 $pkt = "frag";
2910 }
2911
2912 $self->send_packet ($pkt); 3040 $self->send_big_packet ($pkt);
2913} 3041}
2914 3042
2915=item $client->ext_msg ($type, @msg) 3043=item $client->ext_msg ($type, @msg)
2916 3044
2917Sends an ext event to the client. 3045Sends an ext event to the client.
… …
2920 3048
2921sub cf::client::ext_msg($$@) { 3049sub cf::client::ext_msg($$@) {
2922 my ($self, $type, @msg) = @_; 3050 my ($self, $type, @msg) = @_;
2923 3051
2924 if ($self->extcmd == 2) { 3052 if ($self->extcmd == 2) {
2925 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3053 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2926 } elsif ($self->extcmd == 1) { # TODO: remove 3054 } elsif ($self->extcmd == 1) { # TODO: remove
2927 push @msg, msgtype => "event_$type"; 3055 push @msg, msgtype => "event_$type";
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3056 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2929 } 3057 }
2930} 3058}
2931 3059
2932=item $client->ext_reply ($msgid, @msg) 3060=item $client->ext_reply ($msgid, @msg)
2933 3061
… …
2937 3065
2938sub cf::client::ext_reply($$@) { 3066sub cf::client::ext_reply($$@) {
2939 my ($self, $id, @msg) = @_; 3067 my ($self, $id, @msg) = @_;
2940 3068
2941 if ($self->extcmd == 2) { 3069 if ($self->extcmd == 2) {
2942 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3070 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2943 } elsif ($self->extcmd == 1) { 3071 } elsif ($self->extcmd == 1) {
2944 #TODO: version 1, remove 3072 #TODO: version 1, remove
2945 unshift @msg, msgtype => "reply", msgid => $id; 3073 unshift @msg, msgtype => "reply", msgid => $id;
2946 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3074 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2947 } 3075 }
2948} 3076}
2949 3077
2950=item $success = $client->query ($flags, "text", \&cb) 3078=item $success = $client->query ($flags, "text", \&cb)
2951 3079
… …
3052 3180
3053 $coro 3181 $coro
3054} 3182}
3055 3183
3056cf::client->attach ( 3184cf::client->attach (
3057 on_destroy => sub { 3185 on_client_destroy => sub {
3058 my ($ns) = @_; 3186 my ($ns) = @_;
3059 3187
3060 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3188 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3061 }, 3189 },
3062); 3190);
… …
3078our $safe_hole = new Safe::Hole; 3206our $safe_hole = new Safe::Hole;
3079 3207
3080$SIG{FPE} = 'IGNORE'; 3208$SIG{FPE} = 'IGNORE';
3081 3209
3082$safe->permit_only (Opcode::opset qw( 3210$safe->permit_only (Opcode::opset qw(
3083 :base_core :base_mem :base_orig :base_math 3211 :base_core :base_mem :base_orig :base_math :base_loop
3084 grepstart grepwhile mapstart mapwhile 3212 grepstart grepwhile mapstart mapwhile
3085 sort time 3213 sort time
3086)); 3214));
3087 3215
3088# here we export the classes and methods available to script code 3216# here we export the classes and methods available to script code
… …
3140 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3268 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3141 $qcode =~ s/\n/\\n/g; 3269 $qcode =~ s/\n/\\n/g;
3142 3270
3143 %vars = (_dummy => 0) unless %vars; 3271 %vars = (_dummy => 0) unless %vars;
3144 3272
3273 my @res;
3145 local $_; 3274 local $_;
3146 local @safe::cf::_safe_eval_args = values %vars;
3147 3275
3148 my $eval = 3276 my $eval =
3149 "do {\n" 3277 "do {\n"
3150 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3278 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3151 . "#line 0 \"{$qcode}\"\n" 3279 . "#line 0 \"{$qcode}\"\n"
3152 . $code 3280 . $code
3153 . "\n}" 3281 . "\n}"
3154 ; 3282 ;
3155 3283
3284 if ($CFG{safe_eval}) {
3156 sub_generation_inc; 3285 sub_generation_inc;
3286 local @safe::cf::_safe_eval_args = values %vars;
3157 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3287 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3158 sub_generation_inc; 3288 sub_generation_inc;
3289 } else {
3290 local @cf::_safe_eval_args = values %vars;
3291 @res = wantarray ? eval eval : scalar eval $eval;
3292 }
3159 3293
3160 if ($@) { 3294 if ($@) {
3161 warn "$@"; 3295 warn "$@";
3162 warn "while executing safe code '$code'\n"; 3296 warn "while executing safe code '$code'\n";
3163 warn "with arguments " . (join " ", %vars) . "\n"; 3297 warn "with arguments " . (join " ", %vars) . "\n";
… …
3182=cut 3316=cut
3183 3317
3184sub register_script_function { 3318sub register_script_function {
3185 my ($fun, $cb) = @_; 3319 my ($fun, $cb) = @_;
3186 3320
3187 no strict 'refs'; 3321 $fun = "safe::$fun" if $CFG{safe_eval};
3188 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3322 *$fun = $safe_hole->wrap ($cb);
3189} 3323}
3190 3324
3191=back 3325=back
3192 3326
3193=cut 3327=cut
… …
3214 3348
3215 $facedata->{version} == 2 3349 $facedata->{version} == 2
3216 or cf::cleanup "$path: version mismatch, cannot proceed."; 3350 or cf::cleanup "$path: version mismatch, cannot proceed.";
3217 3351
3218 # patch in the exptable 3352 # patch in the exptable
3353 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3219 $facedata->{resource}{"res/exp_table"} = { 3354 $facedata->{resource}{"res/exp_table"} = {
3220 type => FT_RSRC, 3355 type => FT_RSRC,
3221 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3356 data => $exp_table,
3357 hash => (Digest::MD5::md5 $exp_table),
3222 }; 3358 };
3223 cf::cede_to_tick; 3359 cf::cede_to_tick;
3224 3360
3225 { 3361 {
3226 my $faces = $facedata->{faceinfo}; 3362 my $faces = $facedata->{faceinfo};
… …
3228 while (my ($face, $info) = each %$faces) { 3364 while (my ($face, $info) = each %$faces) {
3229 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3365 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3230 3366
3231 cf::face::set_visibility $idx, $info->{visibility}; 3367 cf::face::set_visibility $idx, $info->{visibility};
3232 cf::face::set_magicmap $idx, $info->{magicmap}; 3368 cf::face::set_magicmap $idx, $info->{magicmap};
3233 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3369 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3234 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3370 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3235 3371
3236 cf::cede_to_tick; 3372 cf::cede_to_tick;
3237 } 3373 }
3238 3374
3239 while (my ($face, $info) = each %$faces) { 3375 while (my ($face, $info) = each %$faces) {
… …
3263 3399
3264 cf::anim::invalidate_all; # d'oh 3400 cf::anim::invalidate_all; # d'oh
3265 } 3401 }
3266 3402
3267 { 3403 {
3268 # TODO: for gcfclient pleasure, we should give resources
3269 # that gcfclient doesn't grok a >10000 face index.
3270 my $res = $facedata->{resource}; 3404 my $res = $facedata->{resource};
3271 3405
3272 while (my ($name, $info) = each %$res) { 3406 while (my ($name, $info) = each %$res) {
3273 if (defined $info->{type}) { 3407 if (defined $info->{type}) {
3274 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3408 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3275 my $data;
3276 3409
3277 if ($info->{type} & 1) { 3410 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3278 # prepend meta info
3279
3280 my $meta = $enc->encode ({
3281 name => $name,
3282 %{ $info->{meta} || {} },
3283 });
3284
3285 $data = pack "(w/a*)*", $meta, $info->{data};
3286 } else {
3287 $data = $info->{data};
3288 }
3289
3290 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3291 cf::face::set_type $idx, $info->{type}; 3411 cf::face::set_type $idx, $info->{type};
3292 } else { 3412 } else {
3293 $RESOURCE{$name} = $info; 3413 $RESOURCE{$name} = $info;
3294 } 3414 }
3295 3415
… …
3379 3499
3380 warn "finished reloading resource files\n"; 3500 warn "finished reloading resource files\n";
3381} 3501}
3382 3502
3383sub reload_config { 3503sub reload_config {
3504 warn "reloading config file...\n";
3505
3384 open my $fh, "<:utf8", "$CONFDIR/config" 3506 open my $fh, "<:utf8", "$CONFDIR/config"
3385 or return; 3507 or return;
3386 3508
3387 local $/; 3509 local $/;
3388 *CFG = YAML::Load <$fh>; 3510 *CFG = YAML::XS::Load scalar <$fh>;
3389 3511
3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3512 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3391 3513
3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3514 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3393 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3515 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3397 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3519 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3398 and die "WARNING: m(un)lockall failed: $!\n"; 3520 and die "WARNING: m(un)lockall failed: $!\n";
3399 }; 3521 };
3400 warn $@ if $@; 3522 warn $@ if $@;
3401 } 3523 }
3524
3525 warn "finished reloading resource files\n";
3402} 3526}
3403 3527
3404sub pidfile() { 3528sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3529 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!"; 3530 or die "$PIDFILE: $!";
… …
3434 3558
3435 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3559 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3436 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3560 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3437 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3561 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3438 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3562 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3439
3440 cf::init_experience;
3441 cf::init_anim;
3442 cf::init_attackmess;
3443 cf::init_dynamic;
3444 3563
3445 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3564 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3446 3565
3447 # we must not ever block the main coroutine 3566 # we must not ever block the main coroutine
3448 local $Coro::idle = sub { 3567 local $Coro::idle = sub {
… …
3454 }; 3573 };
3455 3574
3456 evthread_start IO::AIO::poll_fileno; 3575 evthread_start IO::AIO::poll_fileno;
3457 3576
3458 cf::sync_job { 3577 cf::sync_job {
3578 cf::init_experience;
3579 cf::init_anim;
3580 cf::init_attackmess;
3581 cf::init_dynamic;
3582
3583 cf::load_settings;
3584 cf::load_materials;
3585
3459 reload_resources; 3586 reload_resources;
3460 reload_config; 3587 reload_config;
3461 db_init; 3588 db_init;
3462 3589
3463 cf::load_settings;
3464 cf::load_materials;
3465 cf::init_uuid; 3590 cf::init_uuid;
3466 cf::init_signals; 3591 cf::init_signals;
3467 cf::init_commands;
3468 cf::init_skills; 3592 cf::init_skills;
3469 3593
3470 cf::init_beforeplay; 3594 cf::init_beforeplay;
3471 3595
3472 atomic; 3596 atomic;
… …
3479 use POSIX (); 3603 use POSIX ();
3480 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3604 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3481 3605
3482 (pop @POST_INIT)->(0) while @POST_INIT; 3606 (pop @POST_INIT)->(0) while @POST_INIT;
3483 }; 3607 };
3608
3609 cf::object::thawer::errors_are_fatal 0;
3610 warn "parse errors in files are no longer fatal from this point on.\n";
3484 3611
3485 main_loop; 3612 main_loop;
3486} 3613}
3487 3614
3488############################################################################# 3615#############################################################################
… …
3490 3617
3491# install some emergency cleanup handlers 3618# install some emergency cleanup handlers
3492BEGIN { 3619BEGIN {
3493 our %SIGWATCHER = (); 3620 our %SIGWATCHER = ();
3494 for my $signal (qw(INT HUP TERM)) { 3621 for my $signal (qw(INT HUP TERM)) {
3495 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3622 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3496 cf::cleanup "SIG$signal"; 3623 cf::cleanup "SIG$signal";
3497 }; 3624 };
3498 } 3625 }
3499} 3626}
3500 3627
3501sub write_runtime_sync { 3628sub write_runtime_sync {
3629 my $t0 = AE::time;
3630
3502 # first touch the runtime file to show we are still running: 3631 # first touch the runtime file to show we are still running:
3503 # the fsync below can take a very very long time. 3632 # the fsync below can take a very very long time.
3504 3633
3505 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3634 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3506 3635
3507 my $guard = cf::lock_acquire "write_runtime"; 3636 my $guard = cf::lock_acquire "write_runtime";
3508 3637
3509 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3638 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3510 or return; 3639 or return;
3511 3640
3512 my $value = $cf::RUNTIME + 90 + 10; 3641 my $value = $cf::RUNTIME + 90 + 10;
3513 # 10 is the runtime save interval, for a monotonic clock 3642 # 10 is the runtime save interval, for a monotonic clock
3514 # 60 allows for the watchdog to kill the server. 3643 # 60 allows for the watchdog to kill the server.
… …
3527 or return; 3656 or return;
3528 3657
3529 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3658 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3530 and return; 3659 and return;
3531 3660
3532 warn "runtime file written.\n"; 3661 warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3533 3662
3534 1 3663 1
3535} 3664}
3536 3665
3537our $uuid_lock; 3666our $uuid_lock;
… …
3663 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3792 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3664 for my $name (keys %$leaf_symtab) { 3793 for my $name (keys %$leaf_symtab) {
3665 _gv_clear *{"$pkg$name"}; 3794 _gv_clear *{"$pkg$name"};
3666# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3795# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3667 } 3796 }
3668 warn "cleared package $pkg\n";#d#
3669} 3797}
3670 3798
3671sub do_reload_perl() { 3799sub do_reload_perl() {
3672 # can/must only be called in main 3800 # can/must only be called in main
3673 if ($Coro::current != $Coro::main) { 3801 if (in_main) {
3674 warn "can only reload from main coroutine"; 3802 warn "can only reload from main coroutine";
3675 return; 3803 return;
3676 } 3804 }
3677 3805
3678 return if $RELOAD++; 3806 return if $RELOAD++;
3679 3807
3680 my $t1 = EV::time; 3808 my $t1 = AE::time;
3681 3809
3682 while ($RELOAD) { 3810 while ($RELOAD) {
3683 warn "reloading..."; 3811 warn "reloading...";
3684 3812
3685 warn "entering sync_job"; 3813 warn "entering sync_job";
… …
3756 3884
3757 warn "unload completed, starting to reload now"; 3885 warn "unload completed, starting to reload now";
3758 3886
3759 warn "reloading cf.pm"; 3887 warn "reloading cf.pm";
3760 require cf; 3888 require cf;
3761 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3889 cf::_connect_to_perl_1;
3762 3890
3763 warn "loading config and database again"; 3891 warn "loading config and database again";
3764 cf::reload_config; 3892 cf::reload_config;
3765 3893
3766 warn "loading extensions"; 3894 warn "loading extensions";
… …
3788 3916
3789 warn "reloaded"; 3917 warn "reloaded";
3790 --$RELOAD; 3918 --$RELOAD;
3791 } 3919 }
3792 3920
3793 $t1 = EV::time - $t1; 3921 $t1 = AE::time - $t1;
3794 warn "reload completed in ${t1}s\n"; 3922 warn "reload completed in ${t1}s\n";
3795}; 3923};
3796 3924
3797our $RELOAD_WATCHER; # used only during reload 3925our $RELOAD_WATCHER; # used only during reload
3798 3926
… …
3801 # coro crashes during coro_state_free->destroy here. 3929 # coro crashes during coro_state_free->destroy here.
3802 3930
3803 $RELOAD_WATCHER ||= cf::async { 3931 $RELOAD_WATCHER ||= cf::async {
3804 Coro::AIO::aio_wait cache_extensions; 3932 Coro::AIO::aio_wait cache_extensions;
3805 3933
3806 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 3934 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3807 do_reload_perl; 3935 do_reload_perl;
3808 undef $RELOAD_WATCHER; 3936 undef $RELOAD_WATCHER;
3809 }; 3937 };
3810 }; 3938 };
3811} 3939}
… …
3828 3956
3829our @WAIT_FOR_TICK; 3957our @WAIT_FOR_TICK;
3830our @WAIT_FOR_TICK_BEGIN; 3958our @WAIT_FOR_TICK_BEGIN;
3831 3959
3832sub wait_for_tick { 3960sub wait_for_tick {
3833 return if tick_inhibit || $Coro::current == $Coro::main; 3961 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3834 3962
3835 my $signal = new Coro::Signal; 3963 my $signal = new Coro::Signal;
3836 push @WAIT_FOR_TICK, $signal; 3964 push @WAIT_FOR_TICK, $signal;
3837 $signal->wait; 3965 $signal->wait;
3838} 3966}
3839 3967
3840sub wait_for_tick_begin { 3968sub wait_for_tick_begin {
3841 return if tick_inhibit || $Coro::current == $Coro::main; 3969 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3842 3970
3843 my $signal = new Coro::Signal; 3971 my $signal = new Coro::Signal;
3844 push @WAIT_FOR_TICK_BEGIN, $signal; 3972 push @WAIT_FOR_TICK_BEGIN, $signal;
3845 $signal->wait; 3973 $signal->wait;
3846} 3974}
… …
3851 unless ++$bug_warning > 10; 3979 unless ++$bug_warning > 10;
3852 return; 3980 return;
3853 } 3981 }
3854 3982
3855 cf::server_tick; # one server iteration 3983 cf::server_tick; # one server iteration
3984
3985 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3856 3986
3857 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3987 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3858 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 3988 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3859 Coro::async_pool { 3989 Coro::async_pool {
3860 $Coro::current->{desc} = "runtime saver"; 3990 $Coro::current->{desc} = "runtime saver";
… …
3883} 4013}
3884 4014
3885{ 4015{
3886 # configure BDB 4016 # configure BDB
3887 4017
3888 BDB::min_parallel 8; 4018 BDB::min_parallel 16;
3889 BDB::max_poll_reqs $TICK * 0.1; 4019 BDB::max_poll_reqs $TICK * 0.1;
3890 $AnyEvent::BDB::WATCHER->priority (1); 4020 $AnyEvent::BDB::WATCHER->priority (1);
3891 4021
3892 unless ($DB_ENV) { 4022 unless ($DB_ENV) {
3893 $DB_ENV = BDB::db_env_create; 4023 $DB_ENV = BDB::db_env_create;
… …
3974 } 4104 }
3975} 4105}
3976 4106
3977# load additional modules 4107# load additional modules
3978require "cf/$_.pm" for @EXTRA_MODULES; 4108require "cf/$_.pm" for @EXTRA_MODULES;
4109cf::_connect_to_perl_2;
3979 4110
3980END { cf::emergency_save } 4111END { cf::emergency_save }
3981 4112
39821 41131
3983 4114

Diff Legend

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