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.529 by root, Wed Apr 28 11:28:22 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 = 3000;
114our $OUTPUT_RATE_MAX = 1000000;
115
116our $MAX_LINKS = 32; # how many chained exits to follow
117our $VERBOSE_IO = 1;
118
112our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
113our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
114our $NEXT_TICK; 121our $NEXT_TICK;
115our $USE_FSYNC = 1; # use fsync to write maps - default on 122our $USE_FSYNC = 1; # use fsync to write maps - default on
116 123
117our $BDB_DEADLOCK_WATCHER; 124our $BDB_DEADLOCK_WATCHER;
118our $BDB_CHECKPOINT_WATCHER; 125our $BDB_CHECKPOINT_WATCHER;
119our $BDB_TRICKLE_WATCHER; 126our $BDB_TRICKLE_WATCHER;
120our $DB_ENV; 127our $DB_ENV;
121 128
122our @EXTRA_MODULES = qw(pod mapscript); 129our @EXTRA_MODULES = qw(pod match mapscript);
123 130
124our %CFG; 131our %CFG;
125 132
126our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
127our $RUNTIME; 134our $RUNTIME;
… …
161 168
162our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
163 170
164sub cf::map::normalise; 171sub cf::map::normalise;
165 172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
176
166############################################################################# 177#############################################################################
167 178
168%REFLECT = (); 179%REFLECT = ();
169for (@REFLECT) { 180for (@REFLECT) {
170 my $reflect = JSON::XS::decode_json $_; 181 my $reflect = JSON::XS::decode_json $_;
171 $REFLECT{$reflect->{class}} = $reflect; 182 $REFLECT{$reflect->{class}} = $reflect;
172} 183}
173 184
185# this is decidedly evil
186$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
187
174############################################################################# 188#############################################################################
175 189
176=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
177 191
178=over 4 192=over 4
… …
224returns 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
225per 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.
226 240
227=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
228 242
229This array contains the results of the last C<invoke ()> call. When 243This 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 244C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
231that call. 245that call.
232 246
233=item %cf::REFLECT 247=item %cf::REFLECT
234 248
235Contains, for each (C++) class name, a hash reference with information 249Contains, for each (C++) class name, a hash reference with information
236about object members (methods, scalars and arrays) and other metadata, 250about object members (methods, scalars, arrays and flags) and other
237which is useful for introspection. 251metadata, which is useful for introspection.
238 252
239=back 253=back
240 254
241=cut 255=cut
242 256
… …
254$Coro::State::DIEHOOK = sub { 268$Coro::State::DIEHOOK = sub {
255 return unless $^S eq 0; # "eq", not "==" 269 return unless $^S eq 0; # "eq", not "=="
256 270
257 warn Carp::longmess $_[0]; 271 warn Carp::longmess $_[0];
258 272
259 if ($Coro::current == $Coro::main) {#d# 273 if (in_main) {#d#
260 warn "DIEHOOK called in main context, Coro bug?\n";#d# 274 warn "DIEHOOK called in main context, Coro bug?\n";#d#
261 return;#d# 275 return;#d#
262 }#d# 276 }#d#
263 277
264 # kill coroutine otherwise 278 # kill coroutine otherwise
… …
285)) { 299)) {
286 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 300 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
287} 301}
288 302
289$EV::DIED = sub { 303$EV::DIED = sub {
290 warn "error in event callback: @_"; 304 Carp::cluck "error in event callback: @_";
291}; 305};
292 306
293############################################################################# 307#############################################################################
294 308
295=head2 UTILITY FUNCTIONS 309=head2 UTILITY FUNCTIONS
… …
392} 406}
393 407
394=item cf::periodic $interval, $cb 408=item cf::periodic $interval, $cb
395 409
396Like 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
397get spread over timer. 411get spread over time.
398 412
399=cut 413=cut
400 414
401sub periodic($$) { 415sub periodic($$) {
402 my ($interval, $cb) = @_; 416 my ($interval, $cb) = @_;
… …
419 433
420=cut 434=cut
421 435
422our @SLOT_QUEUE; 436our @SLOT_QUEUE;
423our $SLOT_QUEUE; 437our $SLOT_QUEUE;
438our $SLOT_DECAY = 0.9;
424 439
425$SLOT_QUEUE->cancel if $SLOT_QUEUE; 440$SLOT_QUEUE->cancel if $SLOT_QUEUE;
426$SLOT_QUEUE = Coro::async { 441$SLOT_QUEUE = Coro::async {
427 $Coro::current->desc ("timeslot manager"); 442 $Coro::current->desc ("timeslot manager");
428 443
429 my $signal = new Coro::Signal; 444 my $signal = new Coro::Signal;
445 my $busy;
430 446
431 while () { 447 while () {
432 next_job: 448 next_job:
449
433 my $avail = cf::till_tick; 450 my $avail = cf::till_tick;
434 if ($avail > 0.01) { 451
435 for (0 .. $#SLOT_QUEUE) { 452 for (0 .. $#SLOT_QUEUE) {
436 if ($SLOT_QUEUE[$_][0] < $avail) { 453 if ($SLOT_QUEUE[$_][0] <= $avail) {
454 $busy = 0;
437 my $job = splice @SLOT_QUEUE, $_, 1, (); 455 my $job = splice @SLOT_QUEUE, $_, 1, ();
438 $job->[2]->send; 456 $job->[2]->send;
439 Coro::cede; 457 Coro::cede;
440 goto next_job; 458 goto next_job;
441 } 459 } else {
460 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
442 } 461 }
443 } 462 }
444 463
445 if (@SLOT_QUEUE) { 464 if (@SLOT_QUEUE) {
446 # 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
447 push @cf::WAIT_FOR_TICK, $signal; 466 push @cf::WAIT_FOR_TICK, $signal;
448 $signal->wait; 467 $signal->wait;
449 } else { 468 } else {
469 $busy = 0;
450 Coro::schedule; 470 Coro::schedule;
451 } 471 }
452 } 472 }
453}; 473};
454 474
455sub get_slot($;$$) { 475sub get_slot($;$$) {
456 return if tick_inhibit || $Coro::current == $Coro::main; 476 return if tick_inhibit || $Coro::current == $Coro::main;
457 477
458 my ($time, $pri, $name) = @_; 478 my ($time, $pri, $name) = @_;
459 479
460 $time = $TICK * .6 if $time > $TICK * .6; 480 $time = clamp $time, 0.01, $TICK * .6;
481
461 my $sig = new Coro::Signal; 482 my $sig = new Coro::Signal;
462 483
463 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 484 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
464 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 485 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
465 $SLOT_QUEUE->ready; 486 $SLOT_QUEUE->ready;
… …
492 513
493sub sync_job(&) { 514sub sync_job(&) {
494 my ($job) = @_; 515 my ($job) = @_;
495 516
496 if ($Coro::current == $Coro::main) { 517 if ($Coro::current == $Coro::main) {
497 my $time = EV::time; 518 my $time = AE::time;
498 519
499 # this is the main coro, too bad, we have to block 520 # this is the main coro, too bad, we have to block
500 # till the operation succeeds, freezing the server :/ 521 # till the operation succeeds, freezing the server :/
501 522
502 LOG llevError, Carp::longmess "sync job";#d# 523 LOG llevError, Carp::longmess "sync job";#d#
… …
519 } else { 540 } else {
520 EV::loop EV::LOOP_ONESHOT; 541 EV::loop EV::LOOP_ONESHOT;
521 } 542 }
522 } 543 }
523 544
524 my $time = EV::time - $time; 545 my $time = AE::time - $time;
525 546
526 $TICK_START += $time; # do not account sync jobs to server load 547 $TICK_START += $time; # do not account sync jobs to server load
527 548
528 wantarray ? @res : $res[0] 549 wantarray ? @res : $res[0]
529 } else { 550 } else {
… …
573 reset_signals; 594 reset_signals;
574 &$cb 595 &$cb
575 }, @args; 596 }, @args;
576 597
577 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 )
578} 610}
579 611
580=item $coin = coin_from_name $name 612=item $coin = coin_from_name $name
581 613
582=cut 614=cut
… …
1163 1195
1164 sync_job { 1196 sync_job {
1165 if (length $$rdata) { 1197 if (length $$rdata) {
1166 utf8::decode (my $decname = $filename); 1198 utf8::decode (my $decname = $filename);
1167 warn sprintf "saving %s (%d,%d)\n", 1199 warn sprintf "saving %s (%d,%d)\n",
1168 $decname, length $$rdata, scalar @$objs; 1200 $decname, length $$rdata, scalar @$objs
1201 if $VERBOSE_IO;
1169 1202
1170 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1203 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1171 aio_chmod $fh, SAVE_MODE; 1204 aio_chmod $fh, SAVE_MODE;
1172 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1205 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1173 if ($cf::USE_FSYNC) { 1206 if ($cf::USE_FSYNC) {
… …
1230 $av = $st->{objs}; 1263 $av = $st->{objs};
1231 } 1264 }
1232 1265
1233 utf8::decode (my $decname = $filename); 1266 utf8::decode (my $decname = $filename);
1234 warn sprintf "loading %s (%d,%d)\n", 1267 warn sprintf "loading %s (%d,%d)\n",
1235 $decname, length $data, scalar @{$av || []}; 1268 $decname, length $data, scalar @{$av || []}
1269 if $VERBOSE_IO;
1236 1270
1237 ($data, $av) 1271 ($data, $av)
1238} 1272}
1239 1273
1240=head2 COMMAND CALLBACKS 1274=head2 COMMAND CALLBACKS
… …
1299} 1333}
1300 1334
1301use File::Glob (); 1335use File::Glob ();
1302 1336
1303cf::player->attach ( 1337cf::player->attach (
1304 on_command => sub { 1338 on_unknown_command => sub {
1305 my ($pl, $name, $params) = @_; 1339 my ($pl, $name, $params) = @_;
1306 1340
1307 my $cb = $COMMAND{$name} 1341 my $cb = $COMMAND{$name}
1308 or return; 1342 or return;
1309 1343
… …
1388 . "\n};\n1"; 1422 . "\n};\n1";
1389 1423
1390 $todo{$base} = \%ext; 1424 $todo{$base} = \%ext;
1391 } 1425 }
1392 1426
1427 my $pass = 0;
1393 my %done; 1428 my %done;
1394 while (%todo) { 1429 while (%todo) {
1395 my $progress; 1430 my $progress;
1396 1431
1432 ++$pass;
1433
1434 ext:
1397 while (my ($k, $v) = each %todo) { 1435 while (my ($k, $v) = each %todo) {
1398 for (split /,\s*/, $v->{meta}{depends}) { 1436 for (split /,\s*/, $v->{meta}{depends}) {
1399 goto skip 1437 next ext
1400 unless exists $done{$_}; 1438 unless exists $done{$_};
1401 } 1439 }
1402 1440
1403 warn "... loading '$k' into '$v->{pkg}'\n"; 1441 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1404 1442
1405 unless (eval $v->{source}) { 1443 my $active = eval $v->{source};
1444
1445 if (length $@) {
1406 my $msg = $@ ? "$v->{path}: $@\n" 1446 warn "$v->{path}: $@\n";
1407 : "$v->{base}: extension inactive.\n";
1408 1447
1409 if (exists $v->{meta}{mandatory}) {
1410 warn $msg;
1411 cf::cleanup "mandatory extension failed to load, exiting."; 1448 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1412 } 1449 if exists $v->{meta}{mandatory};
1413 1450
1414 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;
1415 } 1460 }
1416
1417 $done{$k} = delete $todo{$k};
1418 push @EXTS, $v->{pkg};
1419 $progress = 1;
1420 } 1461 }
1421 1462
1422 skip: 1463 unless ($progress) {
1423 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1464 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1424 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 }
1425 } 1471 }
1426 }; 1472 };
1427} 1473}
1428 1474
1429############################################################################# 1475#############################################################################
… …
1513 $cf::PLAYER{$login} = $pl 1559 $cf::PLAYER{$login} = $pl
1514 } 1560 }
1515 } 1561 }
1516} 1562}
1517 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
1518sub save($) { 1577sub save($) {
1519 my ($pl) = @_; 1578 my ($pl) = @_;
1520 1579
1521 return if $pl->{deny_save}; 1580 return if $pl->{deny_save};
1522 1581
… …
1527 1586
1528 aio_mkdir playerdir $pl, 0770; 1587 aio_mkdir playerdir $pl, 0770;
1529 $pl->{last_save} = $cf::RUNTIME; 1588 $pl->{last_save} = $cf::RUNTIME;
1530 1589
1531 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];
1532 1594
1533 $pl->save_pl ($path); 1595 $pl->save_pl ($path);
1534 cf::cede_to_tick; 1596 cf::cede_to_tick;
1535} 1597}
1536 1598
… …
1573 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1635 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1574 1636
1575 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1637 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1576 $pl->deactivate; 1638 $pl->deactivate;
1577 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1639 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1578 $pl->ob->check_score;
1579 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1640 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1580 $pl->ns->destroy if $pl->ns; 1641 $pl->ns->destroy if $pl->ns;
1581 1642
1582 my $path = playerdir $pl; 1643 my $path = playerdir $pl;
1583 my $temp = "$path~$cf::RUNTIME~deleting~"; 1644 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1638 \@logins 1699 \@logins
1639} 1700}
1640 1701
1641=item $player->maps 1702=item $player->maps
1642 1703
1704=item cf::player::maps $login
1705
1643Returns an arrayref of map paths that are private for this 1706Returns an arrayref of map paths that are private for this
1644player. May block. 1707player. May block.
1645 1708
1646=cut 1709=cut
1647 1710
… …
1709=cut 1772=cut
1710 1773
1711sub find_by_path($) { 1774sub find_by_path($) {
1712 my ($path) = @_; 1775 my ($path) = @_;
1713 1776
1777 $path =~ s/^~[^\/]*//; # skip ~login
1778
1714 my ($match, $specificity); 1779 my ($match, $specificity);
1715 1780
1716 for my $region (list) { 1781 for my $region (list) {
1717 if ($region->{match} && $path =~ $region->{match}) { 1782 if ($region->{match} && $path =~ $region->{match}) {
1718 ($match, $specificity) = ($region, $region->specificity) 1783 ($match, $specificity) = ($region, $region->specificity)
… …
1749 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1814 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1750 1815
1751 # mit "rum" bekleckern, nicht 1816 # mit "rum" bekleckern, nicht
1752 $self->_create_random_map ( 1817 $self->_create_random_map (
1753 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1818 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1754 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1819 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1755 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1820 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1756 $rmp->{exit_on_final_map}, 1821 $rmp->{exit_on_final_map},
1757 $rmp->{xsize}, $rmp->{ysize}, 1822 $rmp->{xsize}, $rmp->{ysize},
1758 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1823 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1759 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1824 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1781 1846
1782 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1847 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1783} 1848}
1784 1849
1785# also paths starting with '/' 1850# also paths starting with '/'
1786$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1851$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1787 1852
1788sub thawer_merge { 1853sub thawer_merge {
1789 my ($self, $merge) = @_; 1854 my ($self, $merge) = @_;
1790 1855
1791 # we have to keep some variables in memory intact 1856 # we have to keep some variables in memory intact
… …
2005 2070
2006 $cf::MAP{$path} = $map 2071 $cf::MAP{$path} = $map
2007 } 2072 }
2008} 2073}
2009 2074
2010sub pre_load { } 2075sub pre_load { }
2011sub post_load { } 2076#sub post_load { } # XS
2012 2077
2013sub load { 2078sub load {
2014 my ($self) = @_; 2079 my ($self) = @_;
2015 2080
2016 local $self->{deny_reset} = 1; # loading can take a long time 2081 local $self->{deny_reset} = 1; # loading can take a long time
… …
2073 } 2138 }
2074 2139
2075 $self->post_load; 2140 $self->post_load;
2076} 2141}
2077 2142
2143# customize the map for a given player, i.e.
2144# return the _real_ map. used by e.g. per-player
2145# maps to change the path to ~playername/mappath
2078sub customise_for { 2146sub customise_for {
2079 my ($self, $ob) = @_; 2147 my ($self, $ob) = @_;
2080 2148
2081 return find "~" . $ob->name . "/" . $self->{path} 2149 return find "~" . $ob->name . "/" . $self->{path}
2082 if $self->per_player; 2150 if $self->per_player;
… …
2098 or next; 2166 or next;
2099 $neigh = find $neigh, $map 2167 $neigh = find $neigh, $map
2100 or next; 2168 or next;
2101 $neigh->load; 2169 $neigh->load;
2102 2170
2171 # now find the diagonal neighbours
2103 push @neigh, 2172 push @neigh,
2104 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2173 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2105 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2174 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2106 } 2175 }
2107 2176
… …
2159 $MAP_PREFETCHER->prio (6); 2228 $MAP_PREFETCHER->prio (6);
2160 2229
2161 () 2230 ()
2162} 2231}
2163 2232
2233# common code, used by both ->save and ->swapout
2164sub save { 2234sub _save {
2165 my ($self) = @_; 2235 my ($self) = @_;
2166
2167 my $lock = cf::lock_acquire "map_data:$self->{path}";
2168 2236
2169 $self->{last_save} = $cf::RUNTIME; 2237 $self->{last_save} = $cf::RUNTIME;
2170 2238
2171 return unless $self->dirty; 2239 return unless $self->dirty;
2172 2240
… …
2192 } else { 2260 } else {
2193 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2261 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2194 } 2262 }
2195} 2263}
2196 2264
2265sub save {
2266 my ($self) = @_;
2267
2268 my $lock = cf::lock_acquire "map_data:$self->{path}";
2269
2270 $self->_save;
2271}
2272
2197sub swap_out { 2273sub swap_out {
2198 my ($self) = @_; 2274 my ($self) = @_;
2199 2275
2200 # save first because save cedes
2201 $self->save;
2202
2203 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2276 my $lock = cf::lock_acquire "map_data:$self->{path}";
2204 2277
2205 return if $self->players;
2206 return if $self->in_memory != cf::MAP_ACTIVE; 2278 return if $self->in_memory != cf::MAP_ACTIVE;
2207 return if $self->{deny_save}; 2279 return if $self->{deny_save};
2280 return if $self->players;
2208 2281
2282 # first deactivate the map and "unlink" it from the core
2283 $self->deactivate;
2284 $_->clear_links_to ($self) for values %cf::MAP;
2209 $self->in_memory (cf::MAP_SWAPPED); 2285 $self->in_memory (cf::MAP_SWAPPED);
2286
2287 # then atomically save
2288 $self->_save;
2289
2290 # then free the map
2291 $self->clear;
2292}
2293
2294sub reset_at {
2295 my ($self) = @_;
2296
2297 # TODO: safety, remove and allow resettable per-player maps
2298 return 1e99 if $self->{deny_reset};
2299
2300 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2301 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2302
2303 $time + $to
2304}
2305
2306sub should_reset {
2307 my ($self) = @_;
2308
2309 $self->reset_at <= $cf::RUNTIME
2310}
2311
2312sub reset {
2313 my ($self) = @_;
2314
2315 my $lock = cf::lock_acquire "map_data:$self->{path}";
2316
2317 return if $self->players;
2318
2319 warn "resetting map ", $self->path, "\n";
2320
2321 $self->in_memory (cf::MAP_SWAPPED);
2322
2323 # need to save uniques path
2324 unless ($self->{deny_save}) {
2325 my $uniq = $self->uniq_path; utf8::encode $uniq;
2326
2327 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2328 if $uniq;
2329 }
2330
2331 delete $cf::MAP{$self->path};
2210 2332
2211 $self->deactivate; 2333 $self->deactivate;
2212 $_->clear_links_to ($self) for values %cf::MAP; 2334 $_->clear_links_to ($self) for values %cf::MAP;
2213 $self->clear; 2335 $self->clear;
2214}
2215
2216sub reset_at {
2217 my ($self) = @_;
2218
2219 # TODO: safety, remove and allow resettable per-player maps
2220 return 1e99 if $self->{deny_reset};
2221
2222 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2223 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2224
2225 $time + $to
2226}
2227
2228sub should_reset {
2229 my ($self) = @_;
2230
2231 $self->reset_at <= $cf::RUNTIME
2232}
2233
2234sub reset {
2235 my ($self) = @_;
2236
2237 my $lock = cf::lock_acquire "map_data:$self->{path}";
2238
2239 return if $self->players;
2240
2241 warn "resetting map ", $self->path, "\n";
2242
2243 $self->in_memory (cf::MAP_SWAPPED);
2244
2245 # need to save uniques path
2246 unless ($self->{deny_save}) {
2247 my $uniq = $self->uniq_path; utf8::encode $uniq;
2248
2249 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2250 if $uniq;
2251 }
2252
2253 delete $cf::MAP{$self->path};
2254
2255 $self->deactivate;
2256 $_->clear_links_to ($self) for values %cf::MAP;
2257 $self->clear;
2258 2336
2259 $self->unlink_save; 2337 $self->unlink_save;
2260 $self->destroy; 2338 $self->destroy;
2261} 2339}
2262 2340
… …
2270 2348
2271 delete $cf::MAP{$self->path}; 2349 delete $cf::MAP{$self->path};
2272 2350
2273 $self->unlink_save; 2351 $self->unlink_save;
2274 2352
2275 bless $self, "cf::map"; 2353 bless $self, "cf::map::wrap";
2276 delete $self->{deny_reset}; 2354 delete $self->{deny_reset};
2277 $self->{deny_save} = 1; 2355 $self->{deny_save} = 1;
2278 $self->reset_timeout (1); 2356 $self->reset_timeout (1);
2279 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2357 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2280 2358
… …
2337 : normalise $_ 2415 : normalise $_
2338 } @{ aio_readdir $UNIQUEDIR or [] } 2416 } @{ aio_readdir $UNIQUEDIR or [] }
2339 ] 2417 ]
2340} 2418}
2341 2419
2420=item cf::map::static_maps
2421
2422Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2423file in the shared directory excluding F</styles> and F</editor>). May
2424block.
2425
2426=cut
2427
2428sub static_maps() {
2429 my @dirs = "";
2430 my @maps;
2431
2432 while (@dirs) {
2433 my $dir = shift @dirs;
2434
2435 next if $dir eq "/styles" || $dir eq "/editor";
2436
2437 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2438 or return;
2439
2440 for (@$files) {
2441 s/\.map$// or next;
2442 utf8::decode $_;
2443 push @maps, "$dir/$_";
2444 }
2445
2446 push @dirs, map "$dir/$_", @$dirs;
2447 }
2448
2449 \@maps
2450}
2451
2342=back 2452=back
2343 2453
2344=head3 cf::object 2454=head3 cf::object
2345 2455
2346=cut 2456=cut
… …
2478 2588
2479Freezes the player and moves him/her to a special map (C<{link}>). 2589Freezes the player and moves him/her to a special map (C<{link}>).
2480 2590
2481The player should be reasonably safe there for short amounts of time (e.g. 2591The player should be reasonably safe there for short amounts of time (e.g.
2482for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2592for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2483though, as the palyer cannot control the character while it is on the link 2593though, as the player cannot control the character while it is on the link
2484map. 2594map.
2485 2595
2486Will never block. 2596Will never block.
2487 2597
2488=item $player_object->leave_link ($map, $x, $y) 2598=item $player_object->leave_link ($map, $x, $y)
… …
2509sub cf::object::player::enter_link { 2619sub cf::object::player::enter_link {
2510 my ($self) = @_; 2620 my ($self) = @_;
2511 2621
2512 $self->deactivate_recursive; 2622 $self->deactivate_recursive;
2513 2623
2624 ++$self->{_link_recursion};
2625
2514 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2626 return if UNIVERSAL::isa $self->map, "ext::map_link";
2515 2627
2516 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2628 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2517 if $self->map && $self->map->{path} ne "{link}"; 2629 if $self->map && $self->map->{path} ne "{link}";
2518 2630
2519 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2631 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2520} 2632}
2521 2633
2522sub cf::object::player::leave_link { 2634sub cf::object::player::leave_link {
2523 my ($self, $map, $x, $y) = @_; 2635 my ($self, $map, $x, $y) = @_;
2524 2636
… …
2541 ($x, $y) = (-1, -1) 2653 ($x, $y) = (-1, -1)
2542 unless (defined $x) && (defined $y); 2654 unless (defined $x) && (defined $y);
2543 2655
2544 # use -1 or undef as default coordinates, not 0, 0 2656 # use -1 or undef as default coordinates, not 0, 0
2545 ($x, $y) = ($map->enter_x, $map->enter_y) 2657 ($x, $y) = ($map->enter_x, $map->enter_y)
2546 if $x <=0 && $y <= 0; 2658 if $x <= 0 && $y <= 0;
2547 2659
2548 $map->load; 2660 $map->load;
2549 $map->load_neighbours; 2661 $map->load_neighbours;
2550 2662
2551 return unless $self->contr->active; 2663 return unless $self->contr->active;
2552 2664
2553 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2665 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2554 $self->enter_map ($map, $x, $y); 2666 if ($self->enter_map ($map, $x, $y)) {
2555 2667 # entering was successful
2668 delete $self->{_link_recursion};
2556 # only activate afterwards, to support waiting in hooks 2669 # only activate afterwards, to support waiting in hooks
2557 $self->activate_recursive; 2670 $self->activate_recursive;
2558} 2671 }
2559 2672
2673}
2674
2560=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2675=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2561 2676
2562Moves the player to the given map-path and coordinates by first freezing 2677Moves the player to the given map-path and coordinates by first freezing
2563her, loading and preparing them map, calling the provided $check callback 2678her, loading and preparing them map, calling the provided $check callback
2564that has to return the map if sucecssful, and then unfreezes the player on 2679that has to return the map if sucecssful, and then unfreezes the player on
2565the new (success) or old (failed) map position. In either case, $done will 2680the new (success) or old (failed) map position. In either case, $done will
… …
2572 2687
2573our $GOTOGEN; 2688our $GOTOGEN;
2574 2689
2575sub cf::object::player::goto { 2690sub cf::object::player::goto {
2576 my ($self, $path, $x, $y, $check, $done) = @_; 2691 my ($self, $path, $x, $y, $check, $done) = @_;
2692
2693 if ($self->{_link_recursion} >= $MAX_LINKS) {
2694 warn "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2695 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2696 ($path, $x, $y) = @$EMERGENCY_POSITION;
2697 }
2577 2698
2578 # do generation counting so two concurrent goto's will be executed in-order 2699 # do generation counting so two concurrent goto's will be executed in-order
2579 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2700 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2580 2701
2581 $self->enter_link; 2702 $self->enter_link;
… …
2605 my $map = eval { 2726 my $map = eval {
2606 my $map = defined $path ? cf::map::find $path : undef; 2727 my $map = defined $path ? cf::map::find $path : undef;
2607 2728
2608 if ($map) { 2729 if ($map) {
2609 $map = $map->customise_for ($self); 2730 $map = $map->customise_for ($self);
2610 $map = $check->($map) if $check && $map; 2731 $map = $check->($map, $x, $y, $self) if $check && $map;
2611 } else { 2732 } else {
2612 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2733 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2613 } 2734 }
2614 2735
2615 $map 2736 $map
… …
2623 if ($gen == $self->{_goto_generation}) { 2744 if ($gen == $self->{_goto_generation}) {
2624 delete $self->{_goto_generation}; 2745 delete $self->{_goto_generation};
2625 $self->leave_link ($map, $x, $y); 2746 $self->leave_link ($map, $x, $y);
2626 } 2747 }
2627 2748
2628 $done->() if $done; 2749 $done->($self) if $done;
2629 })->prio (1); 2750 })->prio (1);
2630} 2751}
2631 2752
2632=item $player_object->enter_exit ($exit_object) 2753=item $player_object->enter_exit ($exit_object)
2633 2754
… …
2750 2871
2751 utf8::encode $text; 2872 utf8::encode $text;
2752 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2873 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2753} 2874}
2754 2875
2876=item $client->send_big_packet ($pkt)
2877
2878Like C<send_packet>, but tries to compress large packets, and fragments
2879them as required.
2880
2881=cut
2882
2883our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2884
2885sub cf::client::send_big_packet {
2886 my ($self, $pkt) = @_;
2887
2888 # try lzf for large packets
2889 $pkt = "lzf " . Compress::LZF::compress $pkt
2890 if 1024 <= length $pkt and $self->{can_lzf};
2891
2892 # split very large packets
2893 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2894 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2895 $pkt = "frag";
2896 }
2897
2898 $self->send_packet ($pkt);
2899}
2900
2755=item $client->send_msg ($channel, $msg, $color, [extra...]) 2901=item $client->send_msg ($channel, $msg, $color, [extra...])
2756 2902
2757Send a drawinfo or msg packet to the client, formatting the msg for the 2903Send 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 2904client 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 2905the message, with C<log> being the default. If C<$color> is negative, suppress
… …
2761 2907
2762=cut 2908=cut
2763 2909
2764# non-persistent channels (usually the info channel) 2910# non-persistent channels (usually the info channel)
2765our %CHANNEL = ( 2911our %CHANNEL = (
2912 "c/motd" => {
2913 id => "infobox",
2914 title => "MOTD",
2915 reply => undef,
2916 tooltip => "The message of the day",
2917 },
2766 "c/identify" => { 2918 "c/identify" => {
2767 id => "infobox", 2919 id => "infobox",
2768 title => "Identify", 2920 title => "Identify",
2769 reply => undef, 2921 reply => undef,
2770 tooltip => "Items recently identified", 2922 tooltip => "Items recently identified",
… …
2772 "c/examine" => { 2924 "c/examine" => {
2773 id => "infobox", 2925 id => "infobox",
2774 title => "Examine", 2926 title => "Examine",
2775 reply => undef, 2927 reply => undef,
2776 tooltip => "Signs and other items you examined", 2928 tooltip => "Signs and other items you examined",
2929 },
2930 "c/shopinfo" => {
2931 id => "infobox",
2932 title => "Shop Info",
2933 reply => undef,
2934 tooltip => "What your bargaining skill tells you about the shop",
2777 }, 2935 },
2778 "c/book" => { 2936 "c/book" => {
2779 id => "infobox", 2937 id => "infobox",
2780 title => "Book", 2938 title => "Book",
2781 reply => undef, 2939 reply => undef,
… …
2897 my $pkt = "msg " 3055 my $pkt = "msg "
2898 . $self->{json_coder}->encode ( 3056 . $self->{json_coder}->encode (
2899 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3057 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2900 ); 3058 );
2901 3059
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); 3060 $self->send_big_packet ($pkt);
2913} 3061}
2914 3062
2915=item $client->ext_msg ($type, @msg) 3063=item $client->ext_msg ($type, @msg)
2916 3064
2917Sends an ext event to the client. 3065Sends an ext event to the client.
… …
2920 3068
2921sub cf::client::ext_msg($$@) { 3069sub cf::client::ext_msg($$@) {
2922 my ($self, $type, @msg) = @_; 3070 my ($self, $type, @msg) = @_;
2923 3071
2924 if ($self->extcmd == 2) { 3072 if ($self->extcmd == 2) {
2925 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3073 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2926 } elsif ($self->extcmd == 1) { # TODO: remove 3074 } elsif ($self->extcmd == 1) { # TODO: remove
2927 push @msg, msgtype => "event_$type"; 3075 push @msg, msgtype => "event_$type";
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3076 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2929 } 3077 }
2930} 3078}
2931 3079
2932=item $client->ext_reply ($msgid, @msg) 3080=item $client->ext_reply ($msgid, @msg)
2933 3081
… …
2937 3085
2938sub cf::client::ext_reply($$@) { 3086sub cf::client::ext_reply($$@) {
2939 my ($self, $id, @msg) = @_; 3087 my ($self, $id, @msg) = @_;
2940 3088
2941 if ($self->extcmd == 2) { 3089 if ($self->extcmd == 2) {
2942 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3090 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2943 } elsif ($self->extcmd == 1) { 3091 } elsif ($self->extcmd == 1) {
2944 #TODO: version 1, remove 3092 #TODO: version 1, remove
2945 unshift @msg, msgtype => "reply", msgid => $id; 3093 unshift @msg, msgtype => "reply", msgid => $id;
2946 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3094 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2947 } 3095 }
2948} 3096}
2949 3097
2950=item $success = $client->query ($flags, "text", \&cb) 3098=item $success = $client->query ($flags, "text", \&cb)
2951 3099
… …
3052 3200
3053 $coro 3201 $coro
3054} 3202}
3055 3203
3056cf::client->attach ( 3204cf::client->attach (
3057 on_destroy => sub { 3205 on_client_destroy => sub {
3058 my ($ns) = @_; 3206 my ($ns) = @_;
3059 3207
3060 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3208 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3061 }, 3209 },
3062); 3210);
… …
3078our $safe_hole = new Safe::Hole; 3226our $safe_hole = new Safe::Hole;
3079 3227
3080$SIG{FPE} = 'IGNORE'; 3228$SIG{FPE} = 'IGNORE';
3081 3229
3082$safe->permit_only (Opcode::opset qw( 3230$safe->permit_only (Opcode::opset qw(
3083 :base_core :base_mem :base_orig :base_math 3231 :base_core :base_mem :base_orig :base_math :base_loop
3084 grepstart grepwhile mapstart mapwhile 3232 grepstart grepwhile mapstart mapwhile
3085 sort time 3233 sort time
3086)); 3234));
3087 3235
3088# here we export the classes and methods available to script code 3236# here we export the classes and methods available to script code
… …
3140 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3288 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3141 $qcode =~ s/\n/\\n/g; 3289 $qcode =~ s/\n/\\n/g;
3142 3290
3143 %vars = (_dummy => 0) unless %vars; 3291 %vars = (_dummy => 0) unless %vars;
3144 3292
3293 my @res;
3145 local $_; 3294 local $_;
3146 local @safe::cf::_safe_eval_args = values %vars;
3147 3295
3148 my $eval = 3296 my $eval =
3149 "do {\n" 3297 "do {\n"
3150 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3298 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3151 . "#line 0 \"{$qcode}\"\n" 3299 . "#line 0 \"{$qcode}\"\n"
3152 . $code 3300 . $code
3153 . "\n}" 3301 . "\n}"
3154 ; 3302 ;
3155 3303
3304 if ($CFG{safe_eval}) {
3156 sub_generation_inc; 3305 sub_generation_inc;
3306 local @safe::cf::_safe_eval_args = values %vars;
3157 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3307 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3158 sub_generation_inc; 3308 sub_generation_inc;
3309 } else {
3310 local @cf::_safe_eval_args = values %vars;
3311 @res = wantarray ? eval eval : scalar eval $eval;
3312 }
3159 3313
3160 if ($@) { 3314 if ($@) {
3161 warn "$@"; 3315 warn "$@";
3162 warn "while executing safe code '$code'\n"; 3316 warn "while executing safe code '$code'\n";
3163 warn "with arguments " . (join " ", %vars) . "\n"; 3317 warn "with arguments " . (join " ", %vars) . "\n";
… …
3182=cut 3336=cut
3183 3337
3184sub register_script_function { 3338sub register_script_function {
3185 my ($fun, $cb) = @_; 3339 my ($fun, $cb) = @_;
3186 3340
3187 no strict 'refs'; 3341 $fun = "safe::$fun" if $CFG{safe_eval};
3188 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3342 *$fun = $safe_hole->wrap ($cb);
3189} 3343}
3190 3344
3191=back 3345=back
3192 3346
3193=cut 3347=cut
… …
3214 3368
3215 $facedata->{version} == 2 3369 $facedata->{version} == 2
3216 or cf::cleanup "$path: version mismatch, cannot proceed."; 3370 or cf::cleanup "$path: version mismatch, cannot proceed.";
3217 3371
3218 # patch in the exptable 3372 # patch in the exptable
3373 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3219 $facedata->{resource}{"res/exp_table"} = { 3374 $facedata->{resource}{"res/exp_table"} = {
3220 type => FT_RSRC, 3375 type => FT_RSRC,
3221 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3376 data => $exp_table,
3377 hash => (Digest::MD5::md5 $exp_table),
3222 }; 3378 };
3223 cf::cede_to_tick; 3379 cf::cede_to_tick;
3224 3380
3225 { 3381 {
3226 my $faces = $facedata->{faceinfo}; 3382 my $faces = $facedata->{faceinfo};
… …
3228 while (my ($face, $info) = each %$faces) { 3384 while (my ($face, $info) = each %$faces) {
3229 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3385 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3230 3386
3231 cf::face::set_visibility $idx, $info->{visibility}; 3387 cf::face::set_visibility $idx, $info->{visibility};
3232 cf::face::set_magicmap $idx, $info->{magicmap}; 3388 cf::face::set_magicmap $idx, $info->{magicmap};
3233 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3389 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3234 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3390 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3235 3391
3236 cf::cede_to_tick; 3392 cf::cede_to_tick;
3237 } 3393 }
3238 3394
3239 while (my ($face, $info) = each %$faces) { 3395 while (my ($face, $info) = each %$faces) {
… …
3263 3419
3264 cf::anim::invalidate_all; # d'oh 3420 cf::anim::invalidate_all; # d'oh
3265 } 3421 }
3266 3422
3267 { 3423 {
3268 # TODO: for gcfclient pleasure, we should give resources
3269 # that gcfclient doesn't grok a >10000 face index.
3270 my $res = $facedata->{resource}; 3424 my $res = $facedata->{resource};
3271 3425
3272 while (my ($name, $info) = each %$res) { 3426 while (my ($name, $info) = each %$res) {
3273 if (defined $info->{type}) { 3427 if (defined $info->{type}) {
3274 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3428 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3275 my $data;
3276 3429
3277 if ($info->{type} & 1) { 3430 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}; 3431 cf::face::set_type $idx, $info->{type};
3292 } else { 3432 } else {
3293 $RESOURCE{$name} = $info; 3433 $RESOURCE{$name} = $info;
3294 } 3434 }
3295 3435
… …
3379 3519
3380 warn "finished reloading resource files\n"; 3520 warn "finished reloading resource files\n";
3381} 3521}
3382 3522
3383sub reload_config { 3523sub reload_config {
3524 warn "reloading config file...\n";
3525
3384 open my $fh, "<:utf8", "$CONFDIR/config" 3526 open my $fh, "<:utf8", "$CONFDIR/config"
3385 or return; 3527 or return;
3386 3528
3387 local $/; 3529 local $/;
3388 *CFG = YAML::Load <$fh>; 3530 *CFG = YAML::XS::Load scalar <$fh>;
3389 3531
3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3532 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3391 3533
3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3534 $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}; 3535 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3394 3536
3395 if (exists $CFG{mlockall}) { 3537 if (exists $CFG{mlockall}) {
… …
3397 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3539 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3398 and die "WARNING: m(un)lockall failed: $!\n"; 3540 and die "WARNING: m(un)lockall failed: $!\n";
3399 }; 3541 };
3400 warn $@ if $@; 3542 warn $@ if $@;
3401 } 3543 }
3544
3545 warn "finished reloading resource files\n";
3402} 3546}
3403 3547
3404sub pidfile() { 3548sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3549 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!"; 3550 or die "$PIDFILE: $!";
… …
3434 3578
3435 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3579 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3436 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3580 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3437 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3581 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3438 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3582 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 3583
3445 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3584 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3446 3585
3447 # we must not ever block the main coroutine 3586 # we must not ever block the main coroutine
3448 local $Coro::idle = sub { 3587 local $Coro::idle = sub {
… …
3454 }; 3593 };
3455 3594
3456 evthread_start IO::AIO::poll_fileno; 3595 evthread_start IO::AIO::poll_fileno;
3457 3596
3458 cf::sync_job { 3597 cf::sync_job {
3598 cf::init_experience;
3599 cf::init_anim;
3600 cf::init_attackmess;
3601 cf::init_dynamic;
3602
3603 cf::load_settings;
3604 cf::load_materials;
3605
3459 reload_resources; 3606 reload_resources;
3460 reload_config; 3607 reload_config;
3461 db_init; 3608 db_init;
3462 3609
3463 cf::load_settings;
3464 cf::load_materials;
3465 cf::init_uuid; 3610 cf::init_uuid;
3466 cf::init_signals; 3611 cf::init_signals;
3467 cf::init_commands;
3468 cf::init_skills; 3612 cf::init_skills;
3469 3613
3470 cf::init_beforeplay; 3614 cf::init_beforeplay;
3471 3615
3472 atomic; 3616 atomic;
… …
3479 use POSIX (); 3623 use POSIX ();
3480 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3624 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3481 3625
3482 (pop @POST_INIT)->(0) while @POST_INIT; 3626 (pop @POST_INIT)->(0) while @POST_INIT;
3483 }; 3627 };
3628
3629 cf::object::thawer::errors_are_fatal 0;
3630 warn "parse errors in files are no longer fatal from this point on.\n";
3484 3631
3485 main_loop; 3632 main_loop;
3486} 3633}
3487 3634
3488############################################################################# 3635#############################################################################
… …
3490 3637
3491# install some emergency cleanup handlers 3638# install some emergency cleanup handlers
3492BEGIN { 3639BEGIN {
3493 our %SIGWATCHER = (); 3640 our %SIGWATCHER = ();
3494 for my $signal (qw(INT HUP TERM)) { 3641 for my $signal (qw(INT HUP TERM)) {
3495 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3642 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3496 cf::cleanup "SIG$signal"; 3643 cf::cleanup "SIG$signal";
3497 }; 3644 };
3498 } 3645 }
3499} 3646}
3500 3647
3501sub write_runtime_sync { 3648sub write_runtime_sync {
3649 my $t0 = AE::time;
3650
3502 # first touch the runtime file to show we are still running: 3651 # first touch the runtime file to show we are still running:
3503 # the fsync below can take a very very long time. 3652 # the fsync below can take a very very long time.
3504 3653
3505 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef; 3654 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3506 3655
3507 my $guard = cf::lock_acquire "write_runtime"; 3656 my $guard = cf::lock_acquire "write_runtime";
3508 3657
3509 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644 3658 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3510 or return; 3659 or return;
3511 3660
3512 my $value = $cf::RUNTIME + 90 + 10; 3661 my $value = $cf::RUNTIME + 90 + 10;
3513 # 10 is the runtime save interval, for a monotonic clock 3662 # 10 is the runtime save interval, for a monotonic clock
3514 # 60 allows for the watchdog to kill the server. 3663 # 60 allows for the watchdog to kill the server.
… …
3527 or return; 3676 or return;
3528 3677
3529 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3678 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3530 and return; 3679 and return;
3531 3680
3532 warn "runtime file written.\n"; 3681 warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3533 3682
3534 1 3683 1
3535} 3684}
3536 3685
3537our $uuid_lock; 3686our $uuid_lock;
… …
3663 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3812 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3664 for my $name (keys %$leaf_symtab) { 3813 for my $name (keys %$leaf_symtab) {
3665 _gv_clear *{"$pkg$name"}; 3814 _gv_clear *{"$pkg$name"};
3666# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3815# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3667 } 3816 }
3668 warn "cleared package $pkg\n";#d#
3669} 3817}
3670 3818
3671sub do_reload_perl() { 3819sub do_reload_perl() {
3672 # can/must only be called in main 3820 # can/must only be called in main
3673 if ($Coro::current != $Coro::main) { 3821 if (in_main) {
3674 warn "can only reload from main coroutine"; 3822 warn "can only reload from main coroutine";
3675 return; 3823 return;
3676 } 3824 }
3677 3825
3678 return if $RELOAD++; 3826 return if $RELOAD++;
3679 3827
3680 my $t1 = EV::time; 3828 my $t1 = AE::time;
3681 3829
3682 while ($RELOAD) { 3830 while ($RELOAD) {
3683 warn "reloading..."; 3831 warn "reloading...";
3684 3832
3685 warn "entering sync_job"; 3833 warn "entering sync_job";
… …
3756 3904
3757 warn "unload completed, starting to reload now"; 3905 warn "unload completed, starting to reload now";
3758 3906
3759 warn "reloading cf.pm"; 3907 warn "reloading cf.pm";
3760 require cf; 3908 require cf;
3761 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3909 cf::_connect_to_perl_1;
3762 3910
3763 warn "loading config and database again"; 3911 warn "loading config and database again";
3764 cf::reload_config; 3912 cf::reload_config;
3765 3913
3766 warn "loading extensions"; 3914 warn "loading extensions";
… …
3788 3936
3789 warn "reloaded"; 3937 warn "reloaded";
3790 --$RELOAD; 3938 --$RELOAD;
3791 } 3939 }
3792 3940
3793 $t1 = EV::time - $t1; 3941 $t1 = AE::time - $t1;
3794 warn "reload completed in ${t1}s\n"; 3942 warn "reload completed in ${t1}s\n";
3795}; 3943};
3796 3944
3797our $RELOAD_WATCHER; # used only during reload 3945our $RELOAD_WATCHER; # used only during reload
3798 3946
… …
3801 # coro crashes during coro_state_free->destroy here. 3949 # coro crashes during coro_state_free->destroy here.
3802 3950
3803 $RELOAD_WATCHER ||= cf::async { 3951 $RELOAD_WATCHER ||= cf::async {
3804 Coro::AIO::aio_wait cache_extensions; 3952 Coro::AIO::aio_wait cache_extensions;
3805 3953
3806 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub { 3954 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3807 do_reload_perl; 3955 do_reload_perl;
3808 undef $RELOAD_WATCHER; 3956 undef $RELOAD_WATCHER;
3809 }; 3957 };
3810 }; 3958 };
3811} 3959}
… …
3828 3976
3829our @WAIT_FOR_TICK; 3977our @WAIT_FOR_TICK;
3830our @WAIT_FOR_TICK_BEGIN; 3978our @WAIT_FOR_TICK_BEGIN;
3831 3979
3832sub wait_for_tick { 3980sub wait_for_tick {
3833 return if tick_inhibit || $Coro::current == $Coro::main; 3981 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3834 3982
3835 my $signal = new Coro::Signal; 3983 my $signal = new Coro::Signal;
3836 push @WAIT_FOR_TICK, $signal; 3984 push @WAIT_FOR_TICK, $signal;
3837 $signal->wait; 3985 $signal->wait;
3838} 3986}
3839 3987
3840sub wait_for_tick_begin { 3988sub wait_for_tick_begin {
3841 return if tick_inhibit || $Coro::current == $Coro::main; 3989 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3842 3990
3843 my $signal = new Coro::Signal; 3991 my $signal = new Coro::Signal;
3844 push @WAIT_FOR_TICK_BEGIN, $signal; 3992 push @WAIT_FOR_TICK_BEGIN, $signal;
3845 $signal->wait; 3993 $signal->wait;
3846} 3994}
… …
3851 unless ++$bug_warning > 10; 3999 unless ++$bug_warning > 10;
3852 return; 4000 return;
3853 } 4001 }
3854 4002
3855 cf::server_tick; # one server iteration 4003 cf::server_tick; # one server iteration
4004
4005 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3856 4006
3857 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4007 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3858 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4008 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3859 Coro::async_pool { 4009 Coro::async_pool {
3860 $Coro::current->{desc} = "runtime saver"; 4010 $Coro::current->{desc} = "runtime saver";
… …
3883} 4033}
3884 4034
3885{ 4035{
3886 # configure BDB 4036 # configure BDB
3887 4037
3888 BDB::min_parallel 8; 4038 BDB::min_parallel 16;
3889 BDB::max_poll_reqs $TICK * 0.1; 4039 BDB::max_poll_reqs $TICK * 0.1;
3890 $AnyEvent::BDB::WATCHER->priority (1); 4040 $AnyEvent::BDB::WATCHER->priority (1);
3891 4041
3892 unless ($DB_ENV) { 4042 unless ($DB_ENV) {
3893 $DB_ENV = BDB::db_env_create; 4043 $DB_ENV = BDB::db_env_create;
… …
3974 } 4124 }
3975} 4125}
3976 4126
3977# load additional modules 4127# load additional modules
3978require "cf/$_.pm" for @EXTRA_MODULES; 4128require "cf/$_.pm" for @EXTRA_MODULES;
4129cf::_connect_to_perl_2;
3979 4130
3980END { cf::emergency_save } 4131END { cf::emergency_save }
3981 4132
39821 41331
3983 4134

Diff Legend

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