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.395 by root, Sat Nov 10 22:41:59 2007 UTC vs.
Revision 1.440 by root, Mon Aug 11 23:23:41 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
3use utf8; 24use utf8;
4use strict; 25use strict;
5 26
6use Symbol; 27use Symbol;
7use List::Util; 28use List::Util;
8use Socket; 29use Socket;
9use Event; 30use EV;
10use Opcode; 31use Opcode;
11use Safe; 32use Safe;
12use Safe::Hole; 33use Safe::Hole;
13use Storable (); 34use Storable ();
14 35
15use Coro 4.1 (); 36use Coro ();
16use Coro::State; 37use Coro::State;
17use Coro::Handle; 38use Coro::Handle;
18use Coro::Event; 39use Coro::AnyEvent;
19use Coro::Timer; 40use Coro::Timer;
20use Coro::Signal; 41use Coro::Signal;
21use Coro::Semaphore; 42use Coro::Semaphore;
43use Coro::AnyEvent;
22use Coro::AIO; 44use Coro::AIO;
45use Coro::BDB 1.6;
23use Coro::Storable; 46use Coro::Storable;
24use Coro::Util (); 47use Coro::Util ();
25 48
26use JSON::XS (); 49use JSON::XS 2.01 ();
27use BDB (); 50use BDB ();
28use Data::Dumper; 51use Data::Dumper;
29use Digest::MD5; 52use Digest::MD5;
30use Fcntl; 53use Fcntl;
31use YAML::Syck (); 54use YAML ();
32use IO::AIO 2.51 (); 55use IO::AIO ();
33use Time::HiRes; 56use Time::HiRes;
34use Compress::LZF; 57use Compress::LZF;
35use Digest::MD5 (); 58use Digest::MD5 ();
59
60AnyEvent::detect;
36 61
37# configure various modules to our taste 62# configure various modules to our taste
38# 63#
39$Storable::canonical = 1; # reduce rsync transfers 64$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 65Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 66Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
43$Event::Eval = 1; # no idea why this is required, but it is
44
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47 67
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 68$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 69
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 70sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 71
… …
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 90our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 91our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 92our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 93our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 94our $BDBDIR = "$LOCALDIR/db";
95our %RESOURCE;
75 96
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 97our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 98our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 99our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 100our $USE_FSYNC = 1; # use fsync to write maps - default off
83 101
84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER; 102our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER; 103our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER; 104our $BDB_TRICKLE_WATCHER;
88our $DB_ENV; 105our $DB_ENV;
89 106
90our %CFG; 107our %CFG;
91 108
92our $UPTIME; $UPTIME ||= time; 109our $UPTIME; $UPTIME ||= time;
93our $RUNTIME; 110our $RUNTIME;
111our $NOW;
94 112
95our (%PLAYER, %PLAYER_LOADING); # all users 113our (%PLAYER, %PLAYER_LOADING); # all users
96our (%MAP, %MAP_LOADING ); # all maps 114our (%MAP, %MAP_LOADING ); # all maps
97our $LINK_MAP; # the special {link} map, which is always available 115our $LINK_MAP; # the special {link} map, which is always available
98 116
99# used to convert map paths into valid unix filenames by replacing / by ∕ 117# used to convert map paths into valid unix filenames by replacing / by ∕
100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 118our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101 119
102our $LOAD; # a number between 0 (idle) and 1 (too many objects) 120our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing 121our $LOADAVG; # same thing, but with alpha-smoothing
122our $JITTER; # average jitter
104our $tick_start; # for load detecting purposes 123our $TICK_START; # for load detecting purposes
105 124
106binmode STDOUT; 125binmode STDOUT;
107binmode STDERR; 126binmode STDERR;
108 127
109# read virtual server time, if available 128# read virtual server time, if available
… …
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 212 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194 213
195 LOG llevError, $msg; 214 LOG llevError, $msg;
196 }; 215 };
197} 216}
217
218$Coro::State::DIEHOOK = sub {
219 return unless $^S eq 0; # "eq", not "=="
220
221 if ($Coro::current == $Coro::main) {#d#
222 warn "DIEHOOK called in main context, Coro bug?\n";#d#
223 return;#d#
224 }#d#
225
226 # kill coroutine otherwise
227 warn Carp::longmess $_[0];
228 Coro::terminate
229};
230
231$SIG{__DIE__} = sub { }; #d#?
198 232
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 233@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 234@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 235@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 236@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
209for my $pkg (qw( 243for my $pkg (qw(
210 cf::global cf::attachable 244 cf::global cf::attachable
211 cf::object cf::object::player 245 cf::object cf::object::player
212 cf::client cf::player 246 cf::client cf::player
213 cf::arch cf::living 247 cf::arch cf::living
248 cf::map cf::mapspace
214 cf::map cf::party cf::region 249 cf::party cf::region
215)) { 250)) {
216 no strict 'refs'; 251 no strict 'refs';
217 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 252 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218} 253}
219 254
220$Event::DIED = sub { 255$EV::DIED = sub {
221 warn "error in event callback: @_"; 256 warn "error in event callback: @_";
222}; 257};
223 258
224############################################################################# 259#############################################################################
225 260
… …
248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 283 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249 $d 284 $d
250 } || "[unable to dump $_[0]: '$@']"; 285 } || "[unable to dump $_[0]: '$@']";
251} 286}
252 287
253=item $ref = cf::from_json $json 288=item $ref = cf::decode_json $json
254 289
255Converts a JSON string into the corresponding perl data structure. 290Converts a JSON string into the corresponding perl data structure.
256 291
257=item $json = cf::to_json $ref 292=item $json = cf::encode_json $ref
258 293
259Converts a perl data structure into its JSON representation. 294Converts a perl data structure into its JSON representation.
260 295
261=cut 296=cut
262 297
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 298our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264 299
265sub to_json ($) { $json_coder->encode ($_[0]) } 300sub encode_json($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) } 301sub decode_json($) { $json_coder->decode ($_[0]) }
267 302
268=item cf::lock_wait $string 303=item cf::lock_wait $string
269 304
270Wait until the given lock is available. See cf::lock_acquire. 305Wait until the given lock is available. See cf::lock_acquire.
271 306
… …
327 362
328 ! ! $LOCK{$key} 363 ! ! $LOCK{$key}
329} 364}
330 365
331sub freeze_mainloop { 366sub freeze_mainloop {
332 return unless $TICK_WATCHER->is_active; 367 tick_inhibit_inc;
333 368
334 my $guard = Coro::guard { 369 Coro::guard \&tick_inhibit_dec;
335 $TICK_WATCHER->start; 370}
336 }; 371
337 $TICK_WATCHER->stop; 372=item cf::periodic $interval, $cb
338 $guard 373
374Like EV::periodic, but randomly selects a starting point so that the actions
375get spread over timer.
376
377=cut
378
379sub periodic($$) {
380 my ($interval, $cb) = @_;
381
382 my $start = rand List::Util::min 180, $interval;
383
384 EV::periodic $start, $interval, 0, $cb
339} 385}
340 386
341=item cf::get_slot $time[, $priority[, $name]] 387=item cf::get_slot $time[, $priority[, $name]]
342 388
343Allocate $time seconds of blocking CPU time at priority C<$priority>: 389Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
383 } 429 }
384 } 430 }
385}; 431};
386 432
387sub get_slot($;$$) { 433sub get_slot($;$$) {
434 return if tick_inhibit || $Coro::current == $Coro::main;
435
388 my ($time, $pri, $name) = @_; 436 my ($time, $pri, $name) = @_;
389 437
390 $time = $TICK * .6 if $time > $TICK * .6; 438 $time = $TICK * .6 if $time > $TICK * .6;
391 my $sig = new Coro::Signal; 439 my $sig = new Coro::Signal;
392 440
… …
422 470
423sub sync_job(&) { 471sub sync_job(&) {
424 my ($job) = @_; 472 my ($job) = @_;
425 473
426 if ($Coro::current == $Coro::main) { 474 if ($Coro::current == $Coro::main) {
427 my $time = Event::time; 475 my $time = EV::time;
428 476
429 # this is the main coro, too bad, we have to block 477 # this is the main coro, too bad, we have to block
430 # till the operation succeeds, freezing the server :/ 478 # till the operation succeeds, freezing the server :/
431 479
432 LOG llevError, Carp::longmess "sync job";#d# 480 LOG llevError, Carp::longmess "sync job";#d#
433 481
434 # TODO: use suspend/resume instead
435 # (but this is cancel-safe)
436 my $freeze_guard = freeze_mainloop; 482 my $freeze_guard = freeze_mainloop;
437 483
438 my $busy = 1; 484 my $busy = 1;
439 my @res; 485 my @res;
440 486
… …
447 493
448 while ($busy) { 494 while ($busy) {
449 if (Coro::nready) { 495 if (Coro::nready) {
450 Coro::cede_notself; 496 Coro::cede_notself;
451 } else { 497 } else {
452 Event::one_event; 498 EV::loop EV::LOOP_ONESHOT;
453 } 499 }
454 } 500 }
455 501
456 $time = Event::time - $time; 502 my $time = EV::time - $time;
457 503
458 LOG llevError | logBacktrace, Carp::longmess "long sync job"
459 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
460
461 $tick_start += $time; # do not account sync jobs to server load 504 $TICK_START += $time; # do not account sync jobs to server load
462 505
463 wantarray ? @res : $res[0] 506 wantarray ? @res : $res[0]
464 } else { 507 } else {
465 # we are in another coroutine, how wonderful, everything just works 508 # we are in another coroutine, how wonderful, everything just works
466 509
… …
491=item fork_call { }, $args 534=item fork_call { }, $args
492 535
493Executes the given code block with the given arguments in a seperate 536Executes the given code block with the given arguments in a seperate
494process, returning the results. Everything must be serialisable with 537process, returning the results. Everything must be serialisable with
495Coro::Storable. May, of course, block. Note that the executed sub may 538Coro::Storable. May, of course, block. Note that the executed sub may
496never block itself or use any form of Event handling. 539never block itself or use any form of event handling.
497 540
498=cut 541=cut
499 542
500sub fork_call(&@) { 543sub fork_call(&@) {
501 my ($cb, @args) = @_; 544 my ($cb, @args) = @_;
… …
508 reset_signals; 551 reset_signals;
509 &$cb 552 &$cb
510 }, @args; 553 }, @args;
511 554
512 wantarray ? @res : $res[-1] 555 wantarray ? @res : $res[-1]
556}
557
558=item $coin = coin_from_name $name
559
560=cut
561
562our %coin_alias = (
563 "silver" => "silvercoin",
564 "silvercoin" => "silvercoin",
565 "silvercoins" => "silvercoin",
566 "gold" => "goldcoin",
567 "goldcoin" => "goldcoin",
568 "goldcoins" => "goldcoin",
569 "platinum" => "platinacoin",
570 "platinumcoin" => "platinacoin",
571 "platinumcoins" => "platinacoin",
572 "platina" => "platinacoin",
573 "platinacoin" => "platinacoin",
574 "platinacoins" => "platinacoin",
575 "royalty" => "royalty",
576 "royalties" => "royalty",
577);
578
579sub coin_from_name($) {
580 $coin_alias{$_[0]}
581 ? cf::arch::find $coin_alias{$_[0]}
582 : undef
513} 583}
514 584
515=item $value = cf::db_get $family => $key 585=item $value = cf::db_get $family => $key
516 586
517Returns a single value from the environment database. 587Returns a single value from the environment database.
… …
954 } 1024 }
955 1025
956 0 1026 0
957} 1027}
958 1028
959=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1029=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
960 1030
961=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1031=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
962 1032
963Generate an object-specific event with the given arguments. 1033Generate an object-specific event with the given arguments.
964 1034
… …
1042cf::attachable->attach ( 1112cf::attachable->attach (
1043 prio => -1000000, 1113 prio => -1000000,
1044 on_instantiate => sub { 1114 on_instantiate => sub {
1045 my ($obj, $data) = @_; 1115 my ($obj, $data) = @_;
1046 1116
1047 $data = from_json $data; 1117 $data = decode_json $data;
1048 1118
1049 for (@$data) { 1119 for (@$data) {
1050 my ($name, $args) = @$_; 1120 my ($name, $args) = @$_;
1051 1121
1052 $obj->attach ($name, %{$args || {} }); 1122 $obj->attach ($name, %{$args || {} });
… …
1073 utf8::decode (my $decname = $filename); 1143 utf8::decode (my $decname = $filename);
1074 warn sprintf "saving %s (%d,%d)\n", 1144 warn sprintf "saving %s (%d,%d)\n",
1075 $decname, length $$rdata, scalar @$objs; 1145 $decname, length $$rdata, scalar @$objs;
1076 1146
1077 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1147 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1078 chmod SAVE_MODE, $fh; 1148 aio_chmod $fh, SAVE_MODE;
1079 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1149 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1080 aio_fsync $fh if $cf::USE_FSYNC; 1150 aio_fsync $fh if $cf::USE_FSYNC;
1081 close $fh; 1151 aio_close $fh;
1082 1152
1083 if (@$objs) { 1153 if (@$objs) {
1084 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1154 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1085 chmod SAVE_MODE, $fh; 1155 aio_chmod $fh, SAVE_MODE;
1086 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1156 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1087 aio_write $fh, 0, (length $data), $data, 0; 1157 aio_write $fh, 0, (length $data), $data, 0;
1088 aio_fsync $fh if $cf::USE_FSYNC; 1158 aio_fsync $fh if $cf::USE_FSYNC;
1089 close $fh; 1159 aio_close $fh;
1090 aio_rename "$filename.pst~", "$filename.pst"; 1160 aio_rename "$filename.pst~", "$filename.pst";
1091 } 1161 }
1092 } else { 1162 } else {
1093 aio_unlink "$filename.pst"; 1163 aio_unlink "$filename.pst";
1094 } 1164 }
… …
1289 my $msg = $@ ? "$v->{path}: $@\n" 1359 my $msg = $@ ? "$v->{path}: $@\n"
1290 : "$v->{base}: extension inactive.\n"; 1360 : "$v->{base}: extension inactive.\n";
1291 1361
1292 if (exists $v->{meta}{mandatory}) { 1362 if (exists $v->{meta}{mandatory}) {
1293 warn $msg; 1363 warn $msg;
1294 warn "mandatory extension failed to load, exiting.\n"; 1364 cf::cleanup "mandatory extension failed to load, exiting.";
1295 exit 1;
1296 } 1365 }
1297 1366
1298 warn $msg; 1367 warn $msg;
1299 } 1368 }
1300 1369
… …
1389 my $f = new_from_file cf::object::thawer path $login 1458 my $f = new_from_file cf::object::thawer path $login
1390 or return; 1459 or return;
1391 1460
1392 my $pl = cf::player::load_pl $f 1461 my $pl = cf::player::load_pl $f
1393 or return; 1462 or return;
1463
1394 local $cf::PLAYER_LOADING{$login} = $pl; 1464 local $cf::PLAYER_LOADING{$login} = $pl;
1395 $f->resolve_delayed_derefs; 1465 $f->resolve_delayed_derefs;
1396 $cf::PLAYER{$login} = $pl 1466 $cf::PLAYER{$login} = $pl
1397 } 1467 }
1398 } 1468 }
… …
1408 1478
1409 return if $pl->{deny_save}; 1479 return if $pl->{deny_save};
1410 1480
1411 aio_mkdir playerdir $pl, 0770; 1481 aio_mkdir playerdir $pl, 0770;
1412 $pl->{last_save} = $cf::RUNTIME; 1482 $pl->{last_save} = $cf::RUNTIME;
1483
1484 cf::get_slot 0.01;
1413 1485
1414 $pl->save_pl ($path); 1486 $pl->save_pl ($path);
1415 cf::cede_to_tick; 1487 cf::cede_to_tick;
1416} 1488}
1417 1489
… …
1453 $pl->{deny_save} = 1; 1525 $pl->{deny_save} = 1;
1454 $pl->password ("*"); # this should lock out the player until we nuked the dir 1526 $pl->password ("*"); # this should lock out the player until we nuked the dir
1455 1527
1456 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1528 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1457 $pl->deactivate; 1529 $pl->deactivate;
1530 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1531 $pl->ob->check_score;
1458 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1532 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1459 $pl->ns->destroy if $pl->ns; 1533 $pl->ns->destroy if $pl->ns;
1460 1534
1461 my $path = playerdir $pl; 1535 my $path = playerdir $pl;
1462 my $temp = "$path~$cf::RUNTIME~deleting~"; 1536 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1501 1575
1502 for my $login (@$dirs) { 1576 for my $login (@$dirs) {
1503 my $path = path $login; 1577 my $path = path $login;
1504 1578
1505 # a .pst is a dead give-away for a valid player 1579 # a .pst is a dead give-away for a valid player
1506 unless (-e "$path.pst") { 1580 # if no pst file found, open and chekc for blocked users
1581 if (aio_stat "$path.pst") {
1507 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1582 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1508 aio_read $fh, 0, 512, my $buf, 0 or next; 1583 aio_read $fh, 0, 512, my $buf, 0 or next;
1509 $buf !~ /^password -------------$/m or next; # official not-valid tag 1584 $buf !~ /^password -------------$/m or next; # official not-valid tag
1510 } 1585 }
1511 1586
… …
1710our $MAX_RESET = 3600; 1785our $MAX_RESET = 3600;
1711our $DEFAULT_RESET = 3000; 1786our $DEFAULT_RESET = 3000;
1712 1787
1713sub generate_random_map { 1788sub generate_random_map {
1714 my ($self, $rmp) = @_; 1789 my ($self, $rmp) = @_;
1790
1791 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1792
1715 # mit "rum" bekleckern, nicht 1793 # mit "rum" bekleckern, nicht
1716 $self->_create_random_map ( 1794 $self->_create_random_map (
1717 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1795 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1718 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1796 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1719 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1797 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1841 1919
1842# the temporary/swap location 1920# the temporary/swap location
1843sub save_path { 1921sub save_path {
1844 my ($self) = @_; 1922 my ($self) = @_;
1845 1923
1846 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1924 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1847 "$TMPDIR/$path.map" 1925 "$TMPDIR/$path.map"
1848} 1926}
1849 1927
1850# the unique path, undef == no special unique path 1928# the unique path, undef == no special unique path
1851sub uniq_path { 1929sub uniq_path {
1852 my ($self) = @_; 1930 my ($self) = @_;
1853 1931
1854 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1932 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1855 "$UNIQUEDIR/$path" 1933 "$UNIQUEDIR/$path"
1856} 1934}
1857 1935
1858# and all this just because we cannot iterate over 1936# and all this just because we cannot iterate over
1859# all maps in C++... 1937# all maps in C++...
… …
1957 2035
1958 cf::lock_wait "map_data:$path";#d#remove 2036 cf::lock_wait "map_data:$path";#d#remove
1959 cf::lock_wait "map_find:$path"; 2037 cf::lock_wait "map_find:$path";
1960 2038
1961 $cf::MAP{$path} || do { 2039 $cf::MAP{$path} || do {
1962 my $guard1 = cf::lock_acquire "map_find:$path";
1963 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it 2040 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2041 my $guard2 = cf::lock_acquire "map_find:$path";
1964 2042
1965 my $map = new_from_path cf::map $path 2043 my $map = new_from_path cf::map $path
1966 or return; 2044 or return;
1967 2045
1968 $map->{last_save} = $cf::RUNTIME; 2046 $map->{last_save} = $cf::RUNTIME;
… …
1971 or return; 2049 or return;
1972 2050
1973 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2051 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1974 # doing this can freeze the server in a sync job, obviously 2052 # doing this can freeze the server in a sync job, obviously
1975 #$cf::WAIT_FOR_TICK->wait; 2053 #$cf::WAIT_FOR_TICK->wait;
2054 undef $guard2;
1976 undef $guard1; 2055 undef $guard1;
1977 undef $guard2;
1978 $map->reset; 2056 $map->reset;
1979 return find $path; 2057 return find $path;
1980 } 2058 }
1981 2059
1982 $cf::MAP{$path} = $map 2060 $cf::MAP{$path} = $map
… …
2009 my $f = new_from_file cf::object::thawer $self->{load_path}; 2087 my $f = new_from_file cf::object::thawer $self->{load_path};
2010 $f->skip_block; 2088 $f->skip_block;
2011 $self->_load_objects ($f) 2089 $self->_load_objects ($f)
2012 or return; 2090 or return;
2013 2091
2014 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2092 $self->post_load_original
2015 if delete $self->{load_original}; 2093 if delete $self->{load_original};
2016 2094
2017 if (my $uniq = $self->uniq_path) { 2095 if (my $uniq = $self->uniq_path) {
2018 utf8::encode $uniq; 2096 utf8::encode $uniq;
2019 unless (aio_stat $uniq) { 2097 unless (aio_stat $uniq) {
… …
2045 } 2123 }
2046 2124
2047 $self->{last_save} = $cf::RUNTIME; 2125 $self->{last_save} = $cf::RUNTIME;
2048 $self->last_access ($cf::RUNTIME); 2126 $self->last_access ($cf::RUNTIME);
2049 2127
2050 $self->in_memory (cf::MAP_IN_MEMORY); 2128 $self->in_memory (cf::MAP_ACTIVE);
2051 } 2129 }
2052 2130
2053 $self->post_load; 2131 $self->post_load;
2054} 2132}
2055 2133
… …
2113 my ($path, $origin, $load) = @_; 2191 my ($path, $origin, $load) = @_;
2114 2192
2115 $path = normalise $path, $origin && $origin->{path}; 2193 $path = normalise $path, $origin && $origin->{path};
2116 2194
2117 if (my $map = $cf::MAP{$path}) { 2195 if (my $map = $cf::MAP{$path}) {
2118 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2196 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2119 } 2197 }
2120 2198
2121 $MAP_PREFETCH{$path} |= $load; 2199 $MAP_PREFETCH{$path} |= $load;
2122 2200
2123 $MAP_PREFETCHER ||= cf::async { 2201 $MAP_PREFETCHER ||= cf::async {
… …
2160 cf::async { 2238 cf::async {
2161 $Coro::current->{desc} = "map player save"; 2239 $Coro::current->{desc} = "map player save";
2162 $_->contr->save for $self->players; 2240 $_->contr->save for $self->players;
2163 }; 2241 };
2164 2242
2243 cf::get_slot 0.02;
2244
2165 if ($uniq) { 2245 if ($uniq) {
2166 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2246 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2167 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2247 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2168 } else { 2248 } else {
2169 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2249 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
… …
2177 $self->save; 2257 $self->save;
2178 2258
2179 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2259 my $lock = cf::lock_acquire "map_data:$self->{path}";
2180 2260
2181 return if $self->players; 2261 return if $self->players;
2182 return if $self->in_memory != cf::MAP_IN_MEMORY; 2262 return if $self->in_memory != cf::MAP_ACTIVE;
2183 return if $self->{deny_save}; 2263 return if $self->{deny_save};
2184 2264
2185 $self->in_memory (cf::MAP_SWAPPED); 2265 $self->in_memory (cf::MAP_SWAPPED);
2186 2266
2187 $self->deactivate; 2267 $self->deactivate;
… …
2305 2385
2306sub unique_maps() { 2386sub unique_maps() {
2307 [ 2387 [
2308 map { 2388 map {
2309 utf8::decode $_; 2389 utf8::decode $_;
2310 /\.map$/ 2390 s/\.map$//; # TODO future compatibility hack
2391 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2392 ? ()
2311 ? normalise $_ 2393 : normalise $_
2312 : ()
2313 } @{ aio_readdir $UNIQUEDIR or [] } 2394 } @{ aio_readdir $UNIQUEDIR or [] }
2314 ] 2395 ]
2315} 2396}
2316 2397
2317package cf;
2318
2319=back 2398=back
2320 2399
2321=head3 cf::object 2400=head3 cf::object
2322 2401
2323=cut 2402=cut
… …
2326 2405
2327=over 4 2406=over 4
2328 2407
2329=item $ob->inv_recursive 2408=item $ob->inv_recursive
2330 2409
2331Returns the inventory of the object _and_ their inventories, recursively. 2410Returns the inventory of the object I<and> their inventories, recursively,
2411but I<not> the object itself.
2332 2412
2333=cut 2413=cut
2334 2414
2335sub inv_recursive_; 2415sub inv_recursive_;
2336sub inv_recursive_ { 2416sub inv_recursive_ {
… …
2341 inv_recursive_ inv $_[0] 2421 inv_recursive_ inv $_[0]
2342} 2422}
2343 2423
2344=item $ref = $ob->ref 2424=item $ref = $ob->ref
2345 2425
2346creates and returns a persistent reference to an objetc that can be stored as a string. 2426Creates and returns a persistent reference to an object that can be stored as a string.
2347 2427
2348=item $ob = cf::object::deref ($refstring) 2428=item $ob = cf::object::deref ($refstring)
2349 2429
2350returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2430returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2351even if the object actually exists. May block. 2431even if the object actually exists. May block.
… …
2383can be C<undef>. Does the right thing when the player is currently in a 2463can be C<undef>. Does the right thing when the player is currently in a
2384dialogue with the given NPC character. 2464dialogue with the given NPC character.
2385 2465
2386=cut 2466=cut
2387 2467
2468our $SAY_CHANNEL = {
2469 id => "say",
2470 title => "Map",
2471 reply => "say ",
2472 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2473};
2474
2475our $CHAT_CHANNEL = {
2476 id => "chat",
2477 title => "Chat",
2478 reply => "chat ",
2479 tooltip => "Player chat and shouts, global to the server.",
2480};
2481
2388# rough implementation of a future "reply" method that works 2482# rough implementation of a future "reply" method that works
2389# with dialog boxes. 2483# with dialog boxes.
2390#TODO: the first argument must go, split into a $npc->reply_to ( method 2484#TODO: the first argument must go, split into a $npc->reply_to ( method
2391sub cf::object::player::reply($$$;$) { 2485sub cf::object::player::reply($$$;$) {
2392 my ($self, $npc, $msg, $flags) = @_; 2486 my ($self, $npc, $msg, $flags) = @_;
… …
2403 my $dialog = $pl->{npc_dialog}; 2497 my $dialog = $pl->{npc_dialog};
2404 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2498 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2405 2499
2406 } else { 2500 } else {
2407 $msg = $npc->name . " says: $msg" if $npc; 2501 $msg = $npc->name . " says: $msg" if $npc;
2408 $self->message ($msg, $flags); 2502 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2409 } 2503 }
2410 } 2504 }
2411} 2505}
2412 2506
2413=item $object->send_msg ($channel, $msg, $color, [extra...]) 2507=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2520Moves the player to the given map-path and coordinates by first freezing 2614Moves the player to the given map-path and coordinates by first freezing
2521her, loading and preparing them map, calling the provided $check callback 2615her, loading and preparing them map, calling the provided $check callback
2522that has to return the map if sucecssful, and then unfreezes the player on 2616that has to return the map if sucecssful, and then unfreezes the player on
2523the new (success) or old (failed) map position. In either case, $done will 2617the new (success) or old (failed) map position. In either case, $done will
2524be called at the end of this process. 2618be called at the end of this process.
2619
2620Note that $check will be called with a potentially non-loaded map, so if
2621it needs a loaded map it has to call C<< ->load >>.
2525 2622
2526=cut 2623=cut
2527 2624
2528our $GOTOGEN; 2625our $GOTOGEN;
2529 2626
… …
2608} 2705}
2609 2706
2610sub prepare_random_map { 2707sub prepare_random_map {
2611 my ($exit) = @_; 2708 my ($exit) = @_;
2612 2709
2613 my $guard = cf::lock_acquire "exit_prepare:$exit";
2614
2615 # all this does is basically replace the /! path by 2710 # all this does is basically replace the /! path by
2616 # a new random map path (?random/...) with a seed 2711 # a new random map path (?random/...) with a seed
2617 # that depends on the exit object 2712 # that depends on the exit object
2618 2713
2619 my $rmp = parse_random_map_params $exit->msg; 2714 my $rmp = parse_random_map_params $exit->msg;
… …
2621 if ($exit->map) { 2716 if ($exit->map) {
2622 $rmp->{region} = $exit->region->name; 2717 $rmp->{region} = $exit->region->name;
2623 $rmp->{origin_map} = $exit->map->path; 2718 $rmp->{origin_map} = $exit->map->path;
2624 $rmp->{origin_x} = $exit->x; 2719 $rmp->{origin_x} = $exit->x;
2625 $rmp->{origin_y} = $exit->y; 2720 $rmp->{origin_y} = $exit->y;
2721
2722 $exit->map->touch;
2626 } 2723 }
2627 2724
2628 $rmp->{random_seed} ||= $exit->random_seed; 2725 $rmp->{random_seed} ||= $exit->random_seed;
2629 2726
2630 my $data = cf::to_json $rmp; 2727 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2631 my $md5 = Digest::MD5::md5_hex $data; 2728 my $md5 = Digest::MD5::md5_hex $data;
2632 my $meta = "$RANDOMDIR/$md5.meta"; 2729 my $meta = "$RANDOMDIR/$md5.meta";
2633 2730
2634 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2731 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2635 aio_write $fh, 0, (length $data), $data, 0; 2732 aio_write $fh, 0, (length $data), $data, 0;
2636 undef $fh; 2733 undef $fh;
2637 aio_rename "$meta~", $meta; 2734 aio_rename "$meta~", $meta;
2638 2735
2736 my $slaying = "?random/$md5";
2737
2738 if ($exit->valid) {
2639 $exit->slaying ("?random/$md5"); 2739 $exit->slaying ("?random/$md5");
2640 $exit->msg (undef); 2740 $exit->msg (undef);
2741 }
2641 } 2742 }
2642} 2743}
2643 2744
2644sub cf::object::player::enter_exit { 2745sub cf::object::player::enter_exit {
2645 my ($self, $exit) = @_; 2746 my ($self, $exit) = @_;
2646 2747
2647 return unless $self->type == cf::PLAYER; 2748 return unless $self->type == cf::PLAYER;
2648 2749
2649 if ($exit->slaying eq "/!") {
2650 #TODO: this should de-fi-ni-te-ly not be a sync-job
2651 # the problem is that $exit might not survive long enough
2652 # so it needs to be done right now, right here
2653 cf::sync_job { prepare_random_map $exit };
2654 }
2655
2656 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2657 my $hp = $exit->stats->hp;
2658 my $sp = $exit->stats->sp;
2659
2660 $self->enter_link; 2750 $self->enter_link;
2661 2751
2662 # if exit is damned, update players death & WoR home-position
2663 $self->contr->savebed ($slaying, $hp, $sp)
2664 if $exit->flag (FLAG_DAMNED);
2665
2666 (async { 2752 (async {
2667 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2753 $Coro::current->{desc} = "enter_exit";
2668 2754
2669 $self->deactivate_recursive; # just to be sure
2670 unless (eval { 2755 unless (eval {
2756 $self->deactivate_recursive; # just to be sure
2757
2758 # random map handling
2759 {
2760 my $guard = cf::lock_acquire "exit_prepare:$exit";
2761
2762 prepare_random_map $exit
2763 if $exit->slaying eq "/!";
2764 }
2765
2766 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2767 my $x = $exit->stats->hp;
2768 my $y = $exit->stats->sp;
2769
2671 $self->goto ($slaying, $hp, $sp); 2770 $self->goto ($map, $x, $y);
2672 2771
2772 # if exit is damned, update players death & WoR home-position
2773 $self->contr->savebed ($map, $x, $y)
2774 if $exit->flag (cf::FLAG_DAMNED);
2775
2673 1; 2776 1
2674 }) { 2777 }) {
2675 $self->message ("Something went wrong deep within the crossfire server. " 2778 $self->message ("Something went wrong deep within the crossfire server. "
2676 . "I'll try to bring you back to the map you were before. " 2779 . "I'll try to bring you back to the map you were before. "
2677 . "Please report this to the dungeon master!", 2780 . "Please report this to the dungeon master!",
2678 cf::NDI_UNIQUE | cf::NDI_RED); 2781 cf::NDI_UNIQUE | cf::NDI_RED);
… …
2758 id => "infobox", 2861 id => "infobox",
2759 title => "Map Info", 2862 title => "Map Info",
2760 reply => undef, 2863 reply => undef,
2761 tooltip => "Information related to the maps", 2864 tooltip => "Information related to the maps",
2762 }, 2865 },
2866 "c/party" => {
2867 id => "party",
2868 title => "Party",
2869 reply => "gsay ",
2870 tooltip => "Messages and chat related to your party",
2871 },
2763); 2872);
2764 2873
2765sub cf::client::send_msg { 2874sub cf::client::send_msg {
2766 my ($self, $channel, $msg, $color, @extra) = @_; 2875 my ($self, $channel, $msg, $color, @extra) = @_;
2767 2876
… …
3004 3113
3005The following functions and methods are available within a safe environment: 3114The following functions and methods are available within a safe environment:
3006 3115
3007 cf::object 3116 cf::object
3008 contr pay_amount pay_player map x y force_find force_add destroy 3117 contr pay_amount pay_player map x y force_find force_add destroy
3009 insert remove name archname title slaying race decrease_ob_nr 3118 insert remove name archname title slaying race decrease split
3010 3119
3011 cf::object::player 3120 cf::object::player
3012 player 3121 player
3013 3122
3014 cf::player 3123 cf::player
… …
3019 3128
3020=cut 3129=cut
3021 3130
3022for ( 3131for (
3023 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3132 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3024 insert remove inv name archname title slaying race 3133 insert remove inv nrof name archname title slaying race
3025 decrease_ob_nr destroy)], 3134 decrease split destroy change_exp)],
3026 ["cf::object::player" => qw(player)], 3135 ["cf::object::player" => qw(player)],
3027 ["cf::player" => qw(peaceful)], 3136 ["cf::player" => qw(peaceful)],
3028 ["cf::map" => qw(trigger)], 3137 ["cf::map" => qw(trigger)],
3029) { 3138) {
3030 no strict 'refs'; 3139 no strict 'refs';
… …
3135 { 3244 {
3136 my $faces = $facedata->{faceinfo}; 3245 my $faces = $facedata->{faceinfo};
3137 3246
3138 while (my ($face, $info) = each %$faces) { 3247 while (my ($face, $info) = each %$faces) {
3139 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3248 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3249
3140 cf::face::set_visibility $idx, $info->{visibility}; 3250 cf::face::set_visibility $idx, $info->{visibility};
3141 cf::face::set_magicmap $idx, $info->{magicmap}; 3251 cf::face::set_magicmap $idx, $info->{magicmap};
3142 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3252 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3143 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3253 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3144 3254
3145 cf::cede_to_tick; 3255 cf::cede_to_tick;
3146 } 3256 }
3147 3257
3148 while (my ($face, $info) = each %$faces) { 3258 while (my ($face, $info) = each %$faces) {
3149 next unless $info->{smooth}; 3259 next unless $info->{smooth};
3260
3150 my $idx = cf::face::find $face 3261 my $idx = cf::face::find $face
3151 or next; 3262 or next;
3263
3152 if (my $smooth = cf::face::find $info->{smooth}) { 3264 if (my $smooth = cf::face::find $info->{smooth}) {
3153 cf::face::set_smooth $idx, $smooth; 3265 cf::face::set_smooth $idx, $smooth;
3154 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3266 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3155 } else { 3267 } else {
3156 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3268 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3174 { 3286 {
3175 # TODO: for gcfclient pleasure, we should give resources 3287 # TODO: for gcfclient pleasure, we should give resources
3176 # that gcfclient doesn't grok a >10000 face index. 3288 # that gcfclient doesn't grok a >10000 face index.
3177 my $res = $facedata->{resource}; 3289 my $res = $facedata->{resource};
3178 3290
3179 my $soundconf = delete $res->{"res/sound.conf"};
3180
3181 while (my ($name, $info) = each %$res) { 3291 while (my ($name, $info) = each %$res) {
3292 if (defined $info->{type}) {
3182 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3293 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3183 my $data; 3294 my $data;
3184 3295
3185 if ($info->{type} & 1) { 3296 if ($info->{type} & 1) {
3186 # prepend meta info 3297 # prepend meta info
3187 3298
3188 my $meta = $enc->encode ({ 3299 my $meta = $enc->encode ({
3189 name => $name, 3300 name => $name,
3190 %{ $info->{meta} || {} }, 3301 %{ $info->{meta} || {} },
3191 }); 3302 });
3192 3303
3193 $data = pack "(w/a*)*", $meta, $info->{data}; 3304 $data = pack "(w/a*)*", $meta, $info->{data};
3305 } else {
3306 $data = $info->{data};
3307 }
3308
3309 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3310 cf::face::set_type $idx, $info->{type};
3194 } else { 3311 } else {
3195 $data = $info->{data}; 3312 $RESOURCE{$name} = $info;
3196 } 3313 }
3197 3314
3198 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3199 cf::face::set_type $idx, $info->{type};
3200
3201 cf::cede_to_tick; 3315 cf::cede_to_tick;
3202 } 3316 }
3203
3204 if ($soundconf) {
3205 $soundconf = $enc->decode (delete $soundconf->{data});
3206
3207 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3208 my $sound = $soundconf->{compat}[$_]
3209 or next;
3210
3211 my $face = cf::face::find "sound/$sound->[1]";
3212 cf::sound::set $sound->[0] => $face;
3213 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3214 }
3215
3216 while (my ($k, $v) = each %{$soundconf->{event}}) {
3217 my $face = cf::face::find "sound/$v";
3218 cf::sound::set $k => $face;
3219 }
3220 }
3221 } 3317 }
3318
3319 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3222 3320
3223 1 3321 1
3224} 3322}
3323
3324cf::global->attach (on_resource_update => sub {
3325 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3326 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3327
3328 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3329 my $sound = $soundconf->{compat}[$_]
3330 or next;
3331
3332 my $face = cf::face::find "sound/$sound->[1]";
3333 cf::sound::set $sound->[0] => $face;
3334 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3335 }
3336
3337 while (my ($k, $v) = each %{$soundconf->{event}}) {
3338 my $face = cf::face::find "sound/$v";
3339 cf::sound::set $k => $face;
3340 }
3341 }
3342});
3225 3343
3226register_exticmd fx_want => sub { 3344register_exticmd fx_want => sub {
3227 my ($ns, $want) = @_; 3345 my ($ns, $want) = @_;
3228 3346
3229 while (my ($k, $v) = each %$want) { 3347 while (my ($k, $v) = each %$want) {
3230 $ns->fx_want ($k, $v); 3348 $ns->fx_want ($k, $v);
3231 } 3349 }
3232}; 3350};
3351
3352sub load_resource_file($) {
3353 my $guard = lock_acquire "load_resource_file";
3354
3355 my $status = load_resource_file_ $_[0];
3356 get_slot 0.1, 100;
3357 cf::arch::commit_load;
3358
3359 $status
3360}
3233 3361
3234sub reload_regions { 3362sub reload_regions {
3235 # HACK to clear player env face cache, we need some signal framework 3363 # HACK to clear player env face cache, we need some signal framework
3236 # for this (global event?) 3364 # for this (global event?)
3237 %ext::player_env::MUSIC_FACE_CACHE = (); 3365 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3251} 3379}
3252 3380
3253sub reload_archetypes { 3381sub reload_archetypes {
3254 load_resource_file "$DATADIR/archetypes" 3382 load_resource_file "$DATADIR/archetypes"
3255 or die "unable to load archetypes\n"; 3383 or die "unable to load archetypes\n";
3256 #d# NEED to laod twice to resolve forward references
3257 # this really needs to be done in an extra post-pass
3258 # (which needs to be synchronous, so solve it differently)
3259 load_resource_file "$DATADIR/archetypes"
3260 or die "unable to load archetypes\n";
3261} 3384}
3262 3385
3263sub reload_treasures { 3386sub reload_treasures {
3264 load_resource_file "$DATADIR/treasures" 3387 load_resource_file "$DATADIR/treasures"
3265 or die "unable to load treasurelists\n"; 3388 or die "unable to load treasurelists\n";
3266} 3389}
3267 3390
3268sub reload_resources { 3391sub reload_resources {
3269 warn "reloading resource files...\n"; 3392 warn "reloading resource files...\n";
3270 3393
3394 reload_facedata;
3395 reload_archetypes;
3271 reload_regions; 3396 reload_regions;
3272 reload_facedata;
3273 #reload_archetypes;#d#
3274 reload_archetypes;
3275 reload_treasures; 3397 reload_treasures;
3276 3398
3277 warn "finished reloading resource files\n"; 3399 warn "finished reloading resource files\n";
3278} 3400}
3279 3401
3280sub init { 3402sub init {
3403 my $guard = freeze_mainloop;
3404
3405 evthread_start IO::AIO::poll_fileno;
3406
3281 reload_resources; 3407 reload_resources;
3282} 3408}
3283 3409
3284sub reload_config { 3410sub reload_config {
3285 open my $fh, "<:utf8", "$CONFDIR/config" 3411 open my $fh, "<:utf8", "$CONFDIR/config"
3286 or return; 3412 or return;
3287 3413
3288 local $/; 3414 local $/;
3289 *CFG = YAML::Syck::Load <$fh>; 3415 *CFG = YAML::Load <$fh>;
3290 3416
3291 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3417 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3292 3418
3293 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3419 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3294 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3420 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3306 # we must not ever block the main coroutine 3432 # we must not ever block the main coroutine
3307 local $Coro::idle = sub { 3433 local $Coro::idle = sub {
3308 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3434 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3309 (async { 3435 (async {
3310 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3436 $Coro::current->{desc} = "IDLE BUG HANDLER";
3311 Event::one_event; 3437 EV::loop EV::LOOP_ONESHOT;
3312 })->prio (Coro::PRIO_MAX); 3438 })->prio (Coro::PRIO_MAX);
3313 }; 3439 };
3314 3440
3441 {
3442 my $guard = freeze_mainloop;
3315 reload_config; 3443 reload_config;
3316 db_init; 3444 db_init;
3317 load_extensions; 3445 load_extensions;
3318 3446
3319 $TICK_WATCHER->start; 3447 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3448 }
3449
3320 Event::loop; 3450 EV::loop;
3321} 3451}
3322 3452
3323############################################################################# 3453#############################################################################
3324# initialisation and cleanup 3454# initialisation and cleanup
3325 3455
3326# install some emergency cleanup handlers 3456# install some emergency cleanup handlers
3327BEGIN { 3457BEGIN {
3458 our %SIGWATCHER = ();
3328 for my $signal (qw(INT HUP TERM)) { 3459 for my $signal (qw(INT HUP TERM)) {
3329 Event->signal ( 3460 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3330 reentrant => 0,
3331 data => WF_AUTOCANCEL,
3332 signal => $signal,
3333 prio => 0,
3334 cb => sub {
3335 cf::cleanup "SIG$signal"; 3461 cf::cleanup "SIG$signal";
3336 },
3337 ); 3462 };
3338 } 3463 }
3339} 3464}
3340 3465
3341sub write_runtime { 3466sub write_runtime_sync {
3342 my $runtime = "$LOCALDIR/runtime"; 3467 my $runtime = "$LOCALDIR/runtime";
3343 3468
3344 # first touch the runtime file to show we are still running: 3469 # first touch the runtime file to show we are still running:
3345 # the fsync below can take a very very long time. 3470 # the fsync below can take a very very long time.
3346 3471
… …
3372 and return; 3497 and return;
3373 3498
3374 warn "runtime file written.\n"; 3499 warn "runtime file written.\n";
3375 3500
3376 1 3501 1
3502}
3503
3504our $uuid_lock;
3505our $uuid_skip;
3506
3507sub write_uuid_sync($) {
3508 $uuid_skip ||= $_[0];
3509
3510 return if $uuid_lock;
3511 local $uuid_lock = 1;
3512
3513 my $uuid = "$LOCALDIR/uuid";
3514
3515 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3516 or return;
3517
3518 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3519 $uuid_skip = 0;
3520
3521 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3522 and return;
3523
3524 # always fsync - this file is important
3525 aio_fsync $fh
3526 and return;
3527
3528 close $fh
3529 or return;
3530
3531 aio_rename "$uuid~", $uuid
3532 and return;
3533
3534 warn "uuid file written ($value).\n";
3535
3536 1
3537
3538}
3539
3540sub write_uuid($$) {
3541 my ($skip, $sync) = @_;
3542
3543 $sync ? write_uuid_sync $skip
3544 : async { write_uuid_sync $skip };
3377} 3545}
3378 3546
3379sub emergency_save() { 3547sub emergency_save() {
3380 my $freeze_guard = cf::freeze_mainloop; 3548 my $freeze_guard = cf::freeze_mainloop;
3381 3549
… …
3403 warn "end emergency map save\n"; 3571 warn "end emergency map save\n";
3404 3572
3405 warn "begin emergency database checkpoint\n"; 3573 warn "begin emergency database checkpoint\n";
3406 BDB::db_env_txn_checkpoint $DB_ENV; 3574 BDB::db_env_txn_checkpoint $DB_ENV;
3407 warn "end emergency database checkpoint\n"; 3575 warn "end emergency database checkpoint\n";
3576
3577 warn "begin write uuid\n";
3578 write_uuid_sync 1;
3579 warn "end write uuid\n";
3408 }; 3580 };
3409 3581
3410 warn "leave emergency perl save\n"; 3582 warn "leave emergency perl save\n";
3411} 3583}
3412 3584
… …
3427 warn "reloading..."; 3599 warn "reloading...";
3428 3600
3429 warn "entering sync_job"; 3601 warn "entering sync_job";
3430 3602
3431 cf::sync_job { 3603 cf::sync_job {
3432 cf::write_runtime; # external watchdog should not bark 3604 cf::write_runtime_sync; # external watchdog should not bark
3433 cf::emergency_save; 3605 cf::emergency_save;
3434 cf::write_runtime; # external watchdog should not bark 3606 cf::write_runtime_sync; # external watchdog should not bark
3435 3607
3436 warn "syncing database to disk"; 3608 warn "syncing database to disk";
3437 BDB::db_env_txn_checkpoint $DB_ENV; 3609 BDB::db_env_txn_checkpoint $DB_ENV;
3438 3610
3439 # if anything goes wrong in here, we should simply crash as we already saved 3611 # if anything goes wrong in here, we should simply crash as we already saved
3440
3441 warn "cancelling all WF_AUTOCANCEL watchers";
3442 for (Event::all_watchers) {
3443 $_->cancel if $_->data & WF_AUTOCANCEL;
3444 }
3445 3612
3446 warn "flushing outstanding aio requests"; 3613 warn "flushing outstanding aio requests";
3447 for (;;) { 3614 for (;;) {
3448 BDB::flush; 3615 BDB::flush;
3449 IO::AIO::flush; 3616 IO::AIO::flush;
… …
3531 warn "leaving sync_job"; 3698 warn "leaving sync_job";
3532 3699
3533 1 3700 1
3534 } or do { 3701 } or do {
3535 warn $@; 3702 warn $@;
3536 warn "error while reloading, exiting."; 3703 cf::cleanup "error while reloading, exiting.";
3537 exit 1;
3538 }; 3704 };
3539 3705
3540 warn "reloaded"; 3706 warn "reloaded";
3541}; 3707};
3542 3708
… …
3544 3710
3545sub reload_perl() { 3711sub reload_perl() {
3546 # doing reload synchronously and two reloads happen back-to-back, 3712 # doing reload synchronously and two reloads happen back-to-back,
3547 # coro crashes during coro_state_free->destroy here. 3713 # coro crashes during coro_state_free->destroy here.
3548 3714
3549 $RELOAD_WATCHER ||= Event->timer ( 3715 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3550 reentrant => 0,
3551 after => 0,
3552 data => WF_AUTOCANCEL,
3553 cb => sub {
3554 do_reload_perl; 3716 do_reload_perl;
3555 undef $RELOAD_WATCHER; 3717 undef $RELOAD_WATCHER;
3556 },
3557 ); 3718 };
3558} 3719}
3559 3720
3560register_command "reload" => sub { 3721register_command "reload" => sub {
3561 my ($who, $arg) = @_; 3722 my ($who, $arg) = @_;
3562 3723
… …
3575 3736
3576our @WAIT_FOR_TICK; 3737our @WAIT_FOR_TICK;
3577our @WAIT_FOR_TICK_BEGIN; 3738our @WAIT_FOR_TICK_BEGIN;
3578 3739
3579sub wait_for_tick { 3740sub wait_for_tick {
3580 return unless $TICK_WATCHER->is_active;
3581 return if $Coro::current == $Coro::main; 3741 return if tick_inhibit || $Coro::current == $Coro::main;
3582 3742
3583 my $signal = new Coro::Signal; 3743 my $signal = new Coro::Signal;
3584 push @WAIT_FOR_TICK, $signal; 3744 push @WAIT_FOR_TICK, $signal;
3585 $signal->wait; 3745 $signal->wait;
3586} 3746}
3587 3747
3588sub wait_for_tick_begin { 3748sub wait_for_tick_begin {
3589 return unless $TICK_WATCHER->is_active;
3590 return if $Coro::current == $Coro::main; 3749 return if tick_inhibit || $Coro::current == $Coro::main;
3591 3750
3592 my $signal = new Coro::Signal; 3751 my $signal = new Coro::Signal;
3593 push @WAIT_FOR_TICK_BEGIN, $signal; 3752 push @WAIT_FOR_TICK_BEGIN, $signal;
3594 $signal->wait; 3753 $signal->wait;
3595} 3754}
3596 3755
3597$TICK_WATCHER = Event->timer ( 3756sub tick {
3598 reentrant => 0,
3599 parked => 1,
3600 prio => 0,
3601 at => $NEXT_TICK || $TICK,
3602 data => WF_AUTOCANCEL,
3603 cb => sub {
3604 if ($Coro::current != $Coro::main) { 3757 if ($Coro::current != $Coro::main) {
3605 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3758 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3606 unless ++$bug_warning > 10; 3759 unless ++$bug_warning > 10;
3607 return; 3760 return;
3608 } 3761 }
3609 3762
3610 $NOW = $tick_start = Event::time;
3611
3612 cf::server_tick; # one server iteration 3763 cf::server_tick; # one server iteration
3613 3764
3614 $RUNTIME += $TICK;
3615 $NEXT_TICK += $TICK;
3616
3617 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3765 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3618 $NEXT_RUNTIME_WRITE = $NOW + 10; 3766 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3619 Coro::async_pool { 3767 Coro::async_pool {
3620 $Coro::current->{desc} = "runtime saver"; 3768 $Coro::current->{desc} = "runtime saver";
3621 write_runtime 3769 write_runtime_sync
3622 or warn "ERROR: unable to write runtime file: $!"; 3770 or warn "ERROR: unable to write runtime file: $!";
3623 };
3624 } 3771 };
3772 }
3625 3773
3626 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3774 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3627 $sig->send; 3775 $sig->send;
3628 } 3776 }
3629 while (my $sig = shift @WAIT_FOR_TICK) { 3777 while (my $sig = shift @WAIT_FOR_TICK) {
3630 $sig->send; 3778 $sig->send;
3631 } 3779 }
3632 3780
3633 $NOW = Event::time; 3781 $LOAD = ($NOW - $TICK_START) / $TICK;
3634
3635 # if we are delayed by four ticks or more, skip them all
3636 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3637
3638 $TICK_WATCHER->at ($NEXT_TICK);
3639 $TICK_WATCHER->start;
3640
3641 $LOAD = ($NOW - $tick_start) / $TICK;
3642 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3782 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3643 3783
3644 _post_tick; 3784 if (0) {
3785 if ($NEXT_TICK) {
3786 my $jitter = $TICK_START - $NEXT_TICK;
3787 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3788 warn "jitter $JITTER\n";#d#
3789 }
3645 }, 3790 }
3646); 3791}
3647 3792
3648{ 3793{
3794 # configure BDB
3795
3649 BDB::min_parallel 8; 3796 BDB::min_parallel 8;
3650 BDB::max_poll_time $TICK * 0.1; 3797 BDB::max_poll_reqs $TICK * 0.1;
3651 $BDB_POLL_WATCHER = Event->io ( 3798 $AnyEvent::BDB::WATCHER->priority (1);
3652 reentrant => 0,
3653 fd => BDB::poll_fileno,
3654 poll => 'r',
3655 prio => 0,
3656 data => WF_AUTOCANCEL,
3657 cb => \&BDB::poll_cb,
3658 );
3659
3660 BDB::set_sync_prepare {
3661 my $status;
3662 my $current = $Coro::current;
3663 (
3664 sub {
3665 $status = $!;
3666 $current->ready; undef $current;
3667 },
3668 sub {
3669 Coro::schedule while defined $current;
3670 $! = $status;
3671 },
3672 )
3673 };
3674 3799
3675 unless ($DB_ENV) { 3800 unless ($DB_ENV) {
3676 $DB_ENV = BDB::db_env_create; 3801 $DB_ENV = BDB::db_env_create;
3677 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3802 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3678 | BDB::LOG_AUTOREMOVE, 1); 3803 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3804 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3679 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3805 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3680 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3806 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3681 3807
3682 cf::sync_job { 3808 cf::sync_job {
3683 eval { 3809 eval {
… …
3693 3819
3694 cf::cleanup "db_env_open(db): $@" if $@; 3820 cf::cleanup "db_env_open(db): $@" if $@;
3695 }; 3821 };
3696 } 3822 }
3697 3823
3698 $BDB_DEADLOCK_WATCHER = Event->timer ( 3824 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3699 after => 3,
3700 interval => 1,
3701 hard => 1,
3702 prio => 0,
3703 data => WF_AUTOCANCEL,
3704 cb => sub {
3705 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 3825 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3706 },
3707 ); 3826 };
3708 $BDB_CHECKPOINT_WATCHER = Event->timer ( 3827 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3709 after => 11,
3710 interval => 60,
3711 hard => 1,
3712 prio => 0,
3713 data => WF_AUTOCANCEL,
3714 cb => sub {
3715 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 3828 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3716 },
3717 ); 3829 };
3718 $BDB_TRICKLE_WATCHER = Event->timer ( 3830 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3719 after => 5,
3720 interval => 10,
3721 hard => 1,
3722 prio => 0,
3723 data => WF_AUTOCANCEL,
3724 cb => sub {
3725 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 3831 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3726 },
3727 ); 3832 };
3728} 3833}
3729 3834
3730{ 3835{
3836 # configure IO::AIO
3837
3731 IO::AIO::min_parallel 8; 3838 IO::AIO::min_parallel 8;
3732
3733 undef $Coro::AIO::WATCHER;
3734 IO::AIO::max_poll_time $TICK * 0.1; 3839 IO::AIO::max_poll_time $TICK * 0.1;
3735 $AIO_POLL_WATCHER = Event->io ( 3840 undef $AnyEvent::AIO::WATCHER;
3736 reentrant => 0,
3737 data => WF_AUTOCANCEL,
3738 fd => IO::AIO::poll_fileno,
3739 poll => 'r',
3740 prio => 0,
3741 cb => \&IO::AIO::poll_cb,
3742 );
3743} 3841}
3744 3842
3745my $_log_backtrace; 3843my $_log_backtrace;
3746 3844
3747sub _log_backtrace { 3845sub _log_backtrace {

Diff Legend

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