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.356 by root, Tue Sep 4 05:43:21 2007 UTC vs.
Revision 1.493 by root, Mon Oct 26 02:34:37 2009 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 it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# 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 Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
25use 5.10.0;
3use utf8; 26use utf8;
4use strict; 27use strict qw(vars subs);
5 28
6use Symbol; 29use Symbol;
7use List::Util; 30use List::Util;
8use Socket; 31use Socket;
9use Storable; 32use EV;
10use Event;
11use Opcode; 33use Opcode;
12use Safe; 34use Safe;
13use Safe::Hole; 35use Safe::Hole;
36use Storable ();
37use Carp ();
14 38
39use Guard ();
15use Coro 3.64 (); 40use Coro ();
16use Coro::State; 41use Coro::State;
17use Coro::Handle; 42use Coro::Handle;
43use Coro::EV;
18use Coro::Event; 44use Coro::AnyEvent;
19use Coro::Timer; 45use Coro::Timer;
20use Coro::Signal; 46use Coro::Signal;
21use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
22use Coro::AIO; 50use Coro::AIO;
51use Coro::BDB 1.6;
23use Coro::Storable; 52use Coro::Storable;
24use Coro::Util (); 53use Coro::Util ();
25 54
26use JSON::XS (); 55use JSON::XS 2.01 ();
27use BDB (); 56use BDB ();
28use Data::Dumper; 57use Data::Dumper;
29use Digest::MD5; 58use Digest::MD5;
30use Fcntl; 59use Fcntl;
31use YAML::Syck (); 60use YAML::XS ();
32use IO::AIO 2.32 (); 61use IO::AIO ();
33use Time::HiRes; 62use Time::HiRes;
34use Compress::LZF; 63use Compress::LZF;
35use Digest::MD5 (); 64use Digest::MD5 ();
65
66AnyEvent::detect;
36 67
37# configure various modules to our taste 68# configure various modules to our taste
38# 69#
39$Storable::canonical = 1; # reduce rsync transfers 70$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 71Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
72
73$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
74
75# make sure c-lzf reinitialises itself
76Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 77Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42 78
43$Event::Eval = 1; # no idea why this is required, but it is 79# strictly for debugging
44 80$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 81
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 82sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 83
52our %COMMAND = (); 84our %COMMAND = ();
53our %COMMAND_TIME = (); 85our %COMMAND_TIME = ();
… …
56our %EXTCMD = (); 88our %EXTCMD = ();
57our %EXTICMD = (); 89our %EXTICMD = ();
58our %EXT_CORO = (); # coroutines bound to extensions 90our %EXT_CORO = (); # coroutines bound to extensions
59our %EXT_MAP = (); # pluggable maps 91our %EXT_MAP = (); # pluggable maps
60 92
61our $RELOAD; # number of reloads so far 93our $RELOAD; # number of reloads so far, non-zero while in reload
62our @EVENT; 94our @EVENT;
95our @REFLECT; # set by XS
96our %REFLECT; # set by us
63 97
64our $CONFDIR = confdir; 98our $CONFDIR = confdir;
65our $DATADIR = datadir; 99our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir; 103our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 104our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 105our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 106our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 107our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 108our $BDBDIR = "$LOCALDIR/db";
109our $PIDFILE = "$LOCALDIR/pid";
110our $RUNTIMEFILE = "$LOCALDIR/runtime";
111
112our %RESOURCE;
75 113
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 114our $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 115our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 116our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 117our $USE_FSYNC = 1; # use fsync to write maps - default on
83 118
119our $BDB_DEADLOCK_WATCHER;
120our $BDB_CHECKPOINT_WATCHER;
84our $BDB_POLL_WATCHER; 121our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 122our $DB_ENV;
123
124our @EXTRA_MODULES = qw(pod match mapscript);
86 125
87our %CFG; 126our %CFG;
88 127
89our $UPTIME; $UPTIME ||= time; 128our $UPTIME; $UPTIME ||= time;
90our $RUNTIME; 129our $RUNTIME;
130our $NOW;
91 131
92our (%PLAYER, %PLAYER_LOADING); # all users 132our (%PLAYER, %PLAYER_LOADING); # all users
93our (%MAP, %MAP_LOADING ); # all maps 133our (%MAP, %MAP_LOADING ); # all maps
94our $LINK_MAP; # the special {link} map, which is always available 134our $LINK_MAP; # the special {link} map, which is always available
95 135
96# used to convert map paths into valid unix filenames by replacing / by ∕ 136# used to convert map paths into valid unix filenames by replacing / by ∕
97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 137our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98 138
99our $LOAD; # a number between 0 (idle) and 1 (too many objects) 139our $LOAD; # a number between 0 (idle) and 1 (too many objects)
100our $LOADAVG; # same thing, but with alpha-smoothing 140our $LOADAVG; # same thing, but with alpha-smoothing
141our $JITTER; # average jitter
101our $tick_start; # for load detecting purposes 142our $TICK_START; # for load detecting purposes
143
144our @POST_INIT;
145
146our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
147our $REALLY_UNLOOP; # never set to true, please :)
102 148
103binmode STDOUT; 149binmode STDOUT;
104binmode STDERR; 150binmode STDERR;
105 151
106# read virtual server time, if available 152# read virtual server time, if available
107unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 153unless ($RUNTIME || !-e $RUNTIMEFILE) {
108 open my $fh, "<", "$LOCALDIR/runtime" 154 open my $fh, "<", $RUNTIMEFILE
109 or die "unable to read runtime file: $!"; 155 or die "unable to read $RUNTIMEFILE file: $!";
110 $RUNTIME = <$fh> + 0.; 156 $RUNTIME = <$fh> + 0.;
111} 157}
158
159eval "sub TICK() { $TICK } 1" or die;
112 160
113mkdir $_ 161mkdir $_
114 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 162 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
115 163
116our $EMERGENCY_POSITION; 164our $EMERGENCY_POSITION;
117 165
118sub cf::map::normalise; 166sub cf::map::normalise;
167
168#############################################################################
169
170%REFLECT = ();
171for (@REFLECT) {
172 my $reflect = JSON::XS::decode_json $_;
173 $REFLECT{$reflect->{class}} = $reflect;
174}
175
176# this is decidedly evil
177$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
119 178
120############################################################################# 179#############################################################################
121 180
122=head2 GLOBAL VARIABLES 181=head2 GLOBAL VARIABLES
123 182
… …
159 218
160The raw value load value from the last tick. 219The raw value load value from the last tick.
161 220
162=item %cf::CFG 221=item %cf::CFG
163 222
164Configuration for the server, loaded from C</etc/crossfire/config>, or 223Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 224from wherever your confdir points to.
166 225
167=item cf::wait_for_tick, cf::wait_for_tick_begin 226=item cf::wait_for_tick, cf::wait_for_tick_begin
168 227
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 228These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
170returns directly I<after> the tick processing (and consequently, can only wake one process 229returns directly I<after> the tick processing (and consequently, can only wake one process
171per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 230per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
172 231
173=item @cf::INVOKE_RESULTS 232=item @cf::INVOKE_RESULTS
174 233
175This array contains the results of the last C<invoke ()> call. When 234This array contains the results of the last C<invoke ()> call. When
176C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 235C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
177that call. 236that call.
178 237
238=item %cf::REFLECT
239
240Contains, for each (C++) class name, a hash reference with information
241about object members (methods, scalars, arrays and flags) and other
242metadata, which is useful for introspection.
243
179=back 244=back
180 245
181=cut 246=cut
182 247
183BEGIN { 248$Coro::State::WARNHOOK = sub {
184 *CORE::GLOBAL::warn = sub {
185 my $msg = join "", @_; 249 my $msg = join "", @_;
186 250
187 $msg .= "\n" 251 $msg .= "\n"
188 unless $msg =~ /\n$/; 252 unless $msg =~ /\n$/;
189 253
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 254 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191 255
192 utf8::encode $msg;
193 LOG llevError, $msg; 256 LOG llevError, $msg;
194 }; 257};
195} 258
259$Coro::State::DIEHOOK = sub {
260 return unless $^S eq 0; # "eq", not "=="
261
262 warn Carp::longmess $_[0];
263
264 if ($Coro::current == $Coro::main) {#d#
265 warn "DIEHOOK called in main context, Coro bug?\n";#d#
266 return;#d#
267 }#d#
268
269 # kill coroutine otherwise
270 Coro::terminate
271};
196 272
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 273@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 274@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 275@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 276@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
207for my $pkg (qw( 283for my $pkg (qw(
208 cf::global cf::attachable 284 cf::global cf::attachable
209 cf::object cf::object::player 285 cf::object cf::object::player
210 cf::client cf::player 286 cf::client cf::player
211 cf::arch cf::living 287 cf::arch cf::living
288 cf::map cf::mapspace
212 cf::map cf::party cf::region 289 cf::party cf::region
213)) { 290)) {
214 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 291 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 292}
217 293
218$Event::DIED = sub { 294$EV::DIED = sub {
219 warn "error in event callback: @_"; 295 Carp::cluck "error in event callback: @_";
220}; 296};
221 297
222############################################################################# 298#############################################################################
223 299
224=head2 UTILITY FUNCTIONS 300=head2 UTILITY FUNCTIONS
… …
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 322 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d 323 $d
248 } || "[unable to dump $_[0]: '$@']"; 324 } || "[unable to dump $_[0]: '$@']";
249} 325}
250 326
251=item $ref = cf::from_json $json 327=item $ref = cf::decode_json $json
252 328
253Converts a JSON string into the corresponding perl data structure. 329Converts a JSON string into the corresponding perl data structure.
254 330
255=item $json = cf::to_json $ref 331=item $json = cf::encode_json $ref
256 332
257Converts a perl data structure into its JSON representation. 333Converts a perl data structure into its JSON representation.
258 334
259=cut 335=cut
260 336
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 337our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262 338
263sub to_json ($) { $json_coder->encode ($_[0]) } 339sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 340sub decode_json($) { $json_coder->decode ($_[0]) }
341
342=item cf::post_init { BLOCK }
343
344Execute the given codeblock, I<after> all extensions have been (re-)loaded,
345but I<before> the server starts ticking again.
346
347The cdoeblock will have a single boolean argument to indicate whether this
348is a reload or not.
349
350=cut
351
352sub post_init(&) {
353 push @POST_INIT, shift;
354}
265 355
266=item cf::lock_wait $string 356=item cf::lock_wait $string
267 357
268Wait until the given lock is available. See cf::lock_acquire. 358Wait until the given lock is available. See cf::lock_acquire.
269 359
270=item my $lock = cf::lock_acquire $string 360=item my $lock = cf::lock_acquire $string
271 361
272Wait until the given lock is available and then acquires it and returns 362Wait until the given lock is available and then acquires it and returns
273a Coro::guard object. If the guard object gets destroyed (goes out of scope, 363a L<Guard> object. If the guard object gets destroyed (goes out of scope,
274for example when the coroutine gets canceled), the lock is automatically 364for example when the coroutine gets canceled), the lock is automatically
275returned. 365returned.
276 366
277Locks are *not* recursive, locking from the same coro twice results in a 367Locks are *not* recursive, locking from the same coro twice results in a
278deadlocked coro. 368deadlocked coro.
… …
284 374
285Return true if the lock is currently active, i.e. somebody has locked it. 375Return true if the lock is currently active, i.e. somebody has locked it.
286 376
287=cut 377=cut
288 378
289our %LOCK; 379our $LOCKS = new Coro::SemaphoreSet;
290 380
291sub lock_wait($) { 381sub lock_wait($) {
292 my ($key) = @_; 382 $LOCKS->wait ($_[0]);
293
294 # wait for lock, if any
295 while ($LOCK{$key}) {
296 push @{ $LOCK{$key} }, $Coro::current;
297 Coro::schedule;
298 }
299} 383}
300 384
301sub lock_acquire($) { 385sub lock_acquire($) {
302 my ($key) = @_; 386 $LOCKS->guard ($_[0])
303
304 # wait, to be sure we are not locked
305 lock_wait $key;
306
307 $LOCK{$key} = [];
308
309 Coro::guard {
310 # wake up all waiters, to be on the safe side
311 $_->ready for @{ delete $LOCK{$key} };
312 }
313} 387}
314 388
315sub lock_active($) { 389sub lock_active($) {
316 my ($key) = @_; 390 $LOCKS->count ($_[0]) < 1
317
318 ! ! $LOCK{$key}
319} 391}
320 392
321sub freeze_mainloop { 393sub freeze_mainloop {
322 return unless $TICK_WATCHER->is_active; 394 tick_inhibit_inc;
323 395
324 my $guard = Coro::guard { 396 &Guard::guard (\&tick_inhibit_dec);
325 $TICK_WATCHER->start; 397}
326 }; 398
327 $TICK_WATCHER->stop; 399=item cf::periodic $interval, $cb
328 $guard 400
401Like EV::periodic, but randomly selects a starting point so that the actions
402get spread over timer.
403
404=cut
405
406sub periodic($$) {
407 my ($interval, $cb) = @_;
408
409 my $start = rand List::Util::min 180, $interval;
410
411 EV::periodic $start, $interval, 0, $cb
329} 412}
330 413
331=item cf::get_slot $time[, $priority[, $name]] 414=item cf::get_slot $time[, $priority[, $name]]
332 415
333Allocate $time seconds of blocking CPU time at priority C<$priority>: 416Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
344our @SLOT_QUEUE; 427our @SLOT_QUEUE;
345our $SLOT_QUEUE; 428our $SLOT_QUEUE;
346 429
347$SLOT_QUEUE->cancel if $SLOT_QUEUE; 430$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348$SLOT_QUEUE = Coro::async { 431$SLOT_QUEUE = Coro::async {
432 $Coro::current->desc ("timeslot manager");
433
349 my $signal = new Coro::Signal; 434 my $signal = new Coro::Signal;
350 435
351 while () { 436 while () {
352 next_job: 437 next_job:
353 my $avail = cf::till_tick; 438 my $avail = cf::till_tick;
… …
361 } 446 }
362 } 447 }
363 } 448 }
364 449
365 if (@SLOT_QUEUE) { 450 if (@SLOT_QUEUE) {
366 # we do not use wait_For_tick() as it returns immediately when tick is inactive 451 # we do not use wait_for_tick() as it returns immediately when tick is inactive
367 push @cf::WAIT_FOR_TICK, $signal; 452 push @cf::WAIT_FOR_TICK, $signal;
368 $signal->wait; 453 $signal->wait;
369 } else { 454 } else {
370 Coro::schedule; 455 Coro::schedule;
371 } 456 }
372 } 457 }
373}; 458};
374 459
375sub get_slot($;$$) { 460sub get_slot($;$$) {
461 return if tick_inhibit || $Coro::current == $Coro::main;
462
376 my ($time, $pri, $name) = @_; 463 my ($time, $pri, $name) = @_;
377 464
378 $time = $TICK * .6 if $time > $TICK * .6; 465 $time = $TICK * .6 if $time > $TICK * .6;
379 my $sig = new Coro::Signal; 466 my $sig = new Coro::Signal;
380 467
… …
394 481
395BEGIN { *async = \&Coro::async_pool } 482BEGIN { *async = \&Coro::async_pool }
396 483
397=item cf::sync_job { BLOCK } 484=item cf::sync_job { BLOCK }
398 485
399The design of Crossfire TRT requires that the main coroutine ($Coro::main) 486The design of Deliantra requires that the main coroutine ($Coro::main)
400is always able to handle events or runnable, as Crossfire TRT is only 487is always able to handle events or runnable, as Deliantra is only
401partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 488partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable. 489acceptable.
403 490
404If it must be done, put the blocking parts into C<sync_job>. This will run 491If it must be done, put the blocking parts into C<sync_job>. This will run
405the given BLOCK in another coroutine while waiting for the result. The 492the given BLOCK in another coroutine while waiting for the result. The
… …
410 497
411sub sync_job(&) { 498sub sync_job(&) {
412 my ($job) = @_; 499 my ($job) = @_;
413 500
414 if ($Coro::current == $Coro::main) { 501 if ($Coro::current == $Coro::main) {
415 my $time = Event::time; 502 my $time = EV::time;
416 503
417 # this is the main coro, too bad, we have to block 504 # this is the main coro, too bad, we have to block
418 # till the operation succeeds, freezing the server :/ 505 # till the operation succeeds, freezing the server :/
419 506
420 # TODO: use suspend/resume instead 507 LOG llevError, Carp::longmess "sync job";#d#
421 # (but this is cancel-safe) 508
422 my $freeze_guard = freeze_mainloop; 509 my $freeze_guard = freeze_mainloop;
423 510
424 my $busy = 1; 511 my $busy = 1;
425 my @res; 512 my @res;
426 513
427 (async { 514 (async {
515 $Coro::current->desc ("sync job coro");
428 @res = eval { $job->() }; 516 @res = eval { $job->() };
429 warn $@ if $@; 517 warn $@ if $@;
430 undef $busy; 518 undef $busy;
431 })->prio (Coro::PRIO_MAX); 519 })->prio (Coro::PRIO_MAX);
432 520
433 while ($busy) { 521 while ($busy) {
434 Coro::cede or Event::one_event; 522 if (Coro::nready) {
523 Coro::cede_notself;
524 } else {
525 EV::loop EV::LOOP_ONESHOT;
435 } 526 }
527 }
436 528
437 $time = Event::time - $time; 529 my $time = EV::time - $time;
438 530
439 LOG llevError | logBacktrace, Carp::longmess "long sync job"
440 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
441
442 $tick_start += $time; # do not account sync jobs to server load 531 $TICK_START += $time; # do not account sync jobs to server load
443 532
444 wantarray ? @res : $res[0] 533 wantarray ? @res : $res[0]
445 } else { 534 } else {
446 # we are in another coroutine, how wonderful, everything just works 535 # we are in another coroutine, how wonderful, everything just works
447 536
… …
472=item fork_call { }, $args 561=item fork_call { }, $args
473 562
474Executes the given code block with the given arguments in a seperate 563Executes the given code block with the given arguments in a seperate
475process, returning the results. Everything must be serialisable with 564process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may 565Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling. 566never block itself or use any form of event handling.
478 567
479=cut 568=cut
480 569
481sub fork_call(&@) { 570sub fork_call(&@) {
482 my ($cb, @args) = @_; 571 my ($cb, @args) = @_;
… …
491 }, @args; 580 }, @args;
492 581
493 wantarray ? @res : $res[-1] 582 wantarray ? @res : $res[-1]
494} 583}
495 584
585=item $coin = coin_from_name $name
586
587=cut
588
589our %coin_alias = (
590 "silver" => "silvercoin",
591 "silvercoin" => "silvercoin",
592 "silvercoins" => "silvercoin",
593 "gold" => "goldcoin",
594 "goldcoin" => "goldcoin",
595 "goldcoins" => "goldcoin",
596 "platinum" => "platinacoin",
597 "platinumcoin" => "platinacoin",
598 "platinumcoins" => "platinacoin",
599 "platina" => "platinacoin",
600 "platinacoin" => "platinacoin",
601 "platinacoins" => "platinacoin",
602 "royalty" => "royalty",
603 "royalties" => "royalty",
604);
605
606sub coin_from_name($) {
607 $coin_alias{$_[0]}
608 ? cf::arch::find $coin_alias{$_[0]}
609 : undef
610}
611
496=item $value = cf::db_get $family => $key 612=item $value = cf::db_get $family => $key
497 613
498Returns a single value from the environment database. 614Returns a single value from the environment database.
499 615
500=item cf::db_put $family => $key => $value 616=item cf::db_put $family => $key => $value
501 617
502Stores the given C<$value> in the family. It can currently store binary 618Stores the given C<$value> in the family. It can currently store binary
503data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 619data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
504 620
621=item $db = cf::db_table "name"
622
623Create and/or open a new database table. The string must not be "db" and must be unique
624within each server.
625
505=cut 626=cut
627
628sub db_table($) {
629 my ($name) = @_;
630 my $db = BDB::db_create $DB_ENV;
631
632 eval {
633 $db->set_flags (BDB::CHKSUM);
634
635 utf8::encode $name;
636 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
637 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
638 cf::cleanup "db_open(db): $!" if $!;
639 };
640 cf::cleanup "db_open(db): $@" if $@;
641
642 $db
643}
506 644
507our $DB; 645our $DB;
508 646
509sub db_init { 647sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job { 648 cf::sync_job {
514 eval { 649 $DB ||= db_table "db";
515 $DB->set_flags (BDB::CHKSUM);
516
517 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
518 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
519 cf::cleanup "db_open(db): $!" if $!;
520 };
521 cf::cleanup "db_open(db): $@" if $@;
522 };
523 } 650 };
524} 651}
525 652
526sub db_get($$) { 653sub db_get($$) {
527 my $key = "$_[0]/$_[1]"; 654 my $key = "$_[0]/$_[1]";
528 655
… …
626 753
627############################################################################# 754#############################################################################
628 755
629=head2 ATTACHABLE OBJECTS 756=head2 ATTACHABLE OBJECTS
630 757
631Many objects in crossfire are so-called attachable objects. That means you can 758Many objects in deliantra are so-called attachable objects. That means you can
632attach callbacks/event handlers (a collection of which is called an "attachment") 759attach callbacks/event handlers (a collection of which is called an "attachment")
633to it. All such attachable objects support the following methods. 760to it. All such attachable objects support the following methods.
634 761
635In the following description, CLASS can be any of C<global>, C<object> 762In the following description, CLASS can be any of C<global>, C<object>
636C<player>, C<client> or C<map> (i.e. the attachable objects in 763C<player>, C<client> or C<map> (i.e. the attachable objects in
637Crossfire TRT). 764Deliantra).
638 765
639=over 4 766=over 4
640 767
641=item $attachable->attach ($attachment, key => $value...) 768=item $attachable->attach ($attachment, key => $value...)
642 769
… …
686=item cf::CLASS::attachment $name, ... 813=item cf::CLASS::attachment $name, ...
687 814
688Register an attachment by C<$name> through which attachable objects of the 815Register an attachment by C<$name> through which attachable objects of the
689given CLASS can refer to this attachment. 816given CLASS can refer to this attachment.
690 817
691Some classes such as crossfire maps and objects can specify attachments 818Some classes such as deliantra maps and objects can specify attachments
692that are attached at load/instantiate time, thus the need for a name. 819that are attached at load/instantiate time, thus the need for a name.
693 820
694These calls expect any number of the following handler/hook descriptions: 821These calls expect any number of the following handler/hook descriptions:
695 822
696=over 4 823=over 4
… …
924 } 1051 }
925 1052
926 0 1053 0
927} 1054}
928 1055
929=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1056=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
930 1057
931=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1058=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
932 1059
933Generate an object-specific event with the given arguments. 1060Generate an object-specific event with the given arguments.
934 1061
… …
940 1067
941=cut 1068=cut
942 1069
943############################################################################# 1070#############################################################################
944# object support 1071# object support
945#
946 1072
1073sub _object_equal($$);
1074sub _object_equal($$) {
1075 my ($a, $b) = @_;
1076
1077 return 0 unless (ref $a) eq (ref $b);
1078
1079 if ("HASH" eq ref $a) {
1080 my @ka = keys %$a;
1081 my @kb = keys %$b;
1082
1083 return 0 if @ka != @kb;
1084
1085 for (0 .. $#ka) {
1086 return 0 unless $ka[$_] eq $kb[$_];
1087 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1088 }
1089
1090 } elsif ("ARRAY" eq ref $a) {
1091
1092 return 0 if @$a != @$b;
1093
1094 for (0 .. $#$a) {
1095 return 0 unless _object_equal $a->[$_], $b->[$_];
1096 }
1097
1098 } elsif ($a ne $b) {
1099 return 0;
1100 }
1101
1102 1
1103}
1104
1105our $SLOW_MERGES;#d#
947sub _can_merge { 1106sub _can_merge {
948 my ($ob1, $ob2) = @_; 1107 my ($ob1, $ob2) = @_;
949 1108
950 local $Storable::canonical = 1; 1109 ++$SLOW_MERGES;#d#
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953 1110
954 $fob1 eq $fob2 1111 # we do the slow way here
1112 return _object_equal $ob1, $ob2
955} 1113}
956 1114
957sub reattach { 1115sub reattach {
958 # basically do the same as instantiate, without calling instantiate 1116 # basically do the same as instantiate, without calling instantiate
959 my ($obj) = @_; 1117 my ($obj) = @_;
960 1118
1119 # no longer needed after getting rid of delete_package?
961 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1120 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
962 1121
963 my $registry = $obj->registry; 1122 my $registry = $obj->registry;
964 1123
965 @$registry = (); 1124 @$registry = ();
966 1125
… …
981cf::attachable->attach ( 1140cf::attachable->attach (
982 prio => -1000000, 1141 prio => -1000000,
983 on_instantiate => sub { 1142 on_instantiate => sub {
984 my ($obj, $data) = @_; 1143 my ($obj, $data) = @_;
985 1144
986 $data = from_json $data; 1145 $data = decode_json $data;
987 1146
988 for (@$data) { 1147 for (@$data) {
989 my ($name, $args) = @$_; 1148 my ($name, $args) = @$_;
990 1149
991 $obj->attach ($name, %{$args || {} }); 1150 $obj->attach ($name, %{$args || {} });
… …
1005); 1164);
1006 1165
1007sub object_freezer_save { 1166sub object_freezer_save {
1008 my ($filename, $rdata, $objs) = @_; 1167 my ($filename, $rdata, $objs) = @_;
1009 1168
1010 my $guard = cf::lock_acquire "io";
1011
1012 sync_job { 1169 sync_job {
1013 if (length $$rdata) { 1170 if (length $$rdata) {
1171 utf8::decode (my $decname = $filename);
1014 warn sprintf "saving %s (%d,%d)\n", 1172 warn sprintf "saving %s (%d,%d)\n",
1015 $filename, length $$rdata, scalar @$objs; 1173 $decname, length $$rdata, scalar @$objs;
1016 1174
1017 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1175 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1018 chmod SAVE_MODE, $fh; 1176 aio_chmod $fh, SAVE_MODE;
1019 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1177 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1020 aio_fsync $fh if $cf::USE_FSYNC; 1178 if ($cf::USE_FSYNC) {
1179 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1180 aio_fsync $fh;
1181 }
1021 close $fh; 1182 aio_close $fh;
1022 1183
1023 if (@$objs) { 1184 if (@$objs) {
1024 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1185 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1025 chmod SAVE_MODE, $fh; 1186 aio_chmod $fh, SAVE_MODE;
1026 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1187 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1027 aio_write $fh, 0, (length $data), $data, 0; 1188 aio_write $fh, 0, (length $data), $data, 0;
1028 aio_fsync $fh if $cf::USE_FSYNC; 1189 if ($cf::USE_FSYNC) {
1190 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1191 aio_fsync $fh;
1192 }
1029 close $fh; 1193 aio_close $fh;
1030 aio_rename "$filename.pst~", "$filename.pst"; 1194 aio_rename "$filename.pst~", "$filename.pst";
1031 } 1195 }
1032 } else { 1196 } else {
1033 aio_unlink "$filename.pst"; 1197 aio_unlink "$filename.pst";
1034 } 1198 }
1035 1199
1036 aio_rename "$filename~", $filename; 1200 aio_rename "$filename~", $filename;
1201
1202 $filename =~ s%/[^/]+$%%;
1203 aio_pathsync $filename if $cf::USE_FSYNC;
1037 } else { 1204 } else {
1038 warn "FATAL: $filename~: $!\n"; 1205 warn "unable to save objects: $filename~: $!\n";
1039 } 1206 }
1040 } else { 1207 } else {
1041 aio_unlink $filename; 1208 aio_unlink $filename;
1042 aio_unlink "$filename.pst"; 1209 aio_unlink "$filename.pst";
1043 } 1210 }
1044 }; 1211 };
1045
1046 undef $guard;
1047} 1212}
1048 1213
1049sub object_freezer_as_string { 1214sub object_freezer_as_string {
1050 my ($rdata, $objs) = @_; 1215 my ($rdata, $objs) = @_;
1051 1216
… …
1056 1221
1057sub object_thawer_load { 1222sub object_thawer_load {
1058 my ($filename) = @_; 1223 my ($filename) = @_;
1059 1224
1060 my ($data, $av); 1225 my ($data, $av);
1061
1062 my $guard = cf::lock_acquire "io";
1063 1226
1064 (aio_load $filename, $data) >= 0 1227 (aio_load $filename, $data) >= 0
1065 or return; 1228 or return;
1066 1229
1067 unless (aio_stat "$filename.pst") { 1230 unless (aio_stat "$filename.pst") {
1068 (aio_load "$filename.pst", $av) >= 0 1231 (aio_load "$filename.pst", $av) >= 0
1069 or return; 1232 or return;
1070 1233
1071 undef $guard;
1072 $av = eval { (Storable::thaw $av)->{objs} }; 1234 my $st = eval { Coro::Storable::thaw $av };
1235 $av = $st->{objs};
1073 } 1236 }
1074 1237
1238 utf8::decode (my $decname = $filename);
1075 warn sprintf "loading %s (%d)\n", 1239 warn sprintf "loading %s (%d,%d)\n",
1076 $filename, length $data, scalar @{$av || []}; 1240 $decname, length $data, scalar @{$av || []};
1077 1241
1078 ($data, $av) 1242 ($data, $av)
1079} 1243}
1080 1244
1081=head2 COMMAND CALLBACKS 1245=head2 COMMAND CALLBACKS
… …
1137 my ($name, $cb) = @_; 1301 my ($name, $cb) = @_;
1138 1302
1139 $EXTICMD{$name} = $cb; 1303 $EXTICMD{$name} = $cb;
1140} 1304}
1141 1305
1306use File::Glob ();
1307
1142cf::player->attach ( 1308cf::player->attach (
1143 on_command => sub { 1309 on_command => sub {
1144 my ($pl, $name, $params) = @_; 1310 my ($pl, $name, $params) = @_;
1145 1311
1146 my $cb = $COMMAND{$name} 1312 my $cb = $COMMAND{$name}
… …
1178 1344
1179 cf::override; 1345 cf::override;
1180 }, 1346 },
1181); 1347);
1182 1348
1349# "readahead" all extensions
1350sub cache_extensions {
1351 my $grp = IO::AIO::aio_group;
1352
1353 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1354 for (grep /\.ext$/, @{$_[0]}) {
1355 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1356 }
1357 };
1358
1359 $grp
1360}
1361
1183sub load_extensions { 1362sub load_extensions {
1184 cf::sync_job { 1363 cf::sync_job {
1185 my %todo; 1364 my %todo;
1186 1365
1187 for my $path (<$LIBDIR/*.ext>) { 1366 for my $path (<$LIBDIR/*.ext>) {
… …
1206 1385
1207 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1386 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1208 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1387 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1209 1388
1210 $ext{source} = 1389 $ext{source} =
1211 "package $pkg; use strict; use utf8;\n" 1390 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1212 . "#line 1 \"$path\"\n{\n" 1391 . "#line 1 \"$path\"\n{\n"
1213 . $source 1392 . $source
1214 . "\n};\n1"; 1393 . "\n};\n1";
1215 1394
1216 $todo{$base} = \%ext; 1395 $todo{$base} = \%ext;
… …
1232 my $msg = $@ ? "$v->{path}: $@\n" 1411 my $msg = $@ ? "$v->{path}: $@\n"
1233 : "$v->{base}: extension inactive.\n"; 1412 : "$v->{base}: extension inactive.\n";
1234 1413
1235 if (exists $v->{meta}{mandatory}) { 1414 if (exists $v->{meta}{mandatory}) {
1236 warn $msg; 1415 warn $msg;
1237 warn "mandatory extension failed to load, exiting.\n"; 1416 cf::cleanup "mandatory extension failed to load, exiting.";
1238 exit 1;
1239 } 1417 }
1240 1418
1241 warn $msg; 1419 warn $msg;
1242 } 1420 }
1243 1421
… …
1257 1435
1258=back 1436=back
1259 1437
1260=head2 CORE EXTENSIONS 1438=head2 CORE EXTENSIONS
1261 1439
1262Functions and methods that extend core crossfire objects. 1440Functions and methods that extend core deliantra objects.
1263 1441
1264=cut 1442=cut
1265 1443
1266package cf::player; 1444package cf::player;
1267 1445
1268use Coro::AIO; 1446use Coro::AIO;
1269 1447
1270=head3 cf::player 1448=head3 cf::player
1271 1449
1272=over 4 1450=over 4
1451
1452=item cf::player::num_playing
1453
1454Returns the official number of playing players, as per the Crossfire metaserver rules.
1455
1456=cut
1457
1458sub num_playing {
1459 scalar grep
1460 $_->ob->map
1461 && !$_->hidden
1462 && !$_->ob->flag (cf::FLAG_WIZ),
1463 cf::player::list
1464}
1273 1465
1274=item cf::player::find $login 1466=item cf::player::find $login
1275 1467
1276Returns the given player object, loading it if necessary (might block). 1468Returns the given player object, loading it if necessary (might block).
1277 1469
… …
1296 1488
1297sub exists($) { 1489sub exists($) {
1298 my ($login) = @_; 1490 my ($login) = @_;
1299 1491
1300 $cf::PLAYER{$login} 1492 $cf::PLAYER{$login}
1301 or cf::sync_job { !aio_stat path $login } 1493 or !aio_stat path $login
1302} 1494}
1303 1495
1304sub find($) { 1496sub find($) {
1305 return $cf::PLAYER{$_[0]} || do { 1497 return $cf::PLAYER{$_[0]} || do {
1306 my $login = $_[0]; 1498 my $login = $_[0];
… …
1316 aio_unlink +(playerdir $login) . "/$login.pl"; 1508 aio_unlink +(playerdir $login) . "/$login.pl";
1317 1509
1318 my $f = new_from_file cf::object::thawer path $login 1510 my $f = new_from_file cf::object::thawer path $login
1319 or return; 1511 or return;
1320 1512
1321 $f->next;
1322 my $pl = cf::player::load_pl $f 1513 my $pl = cf::player::load_pl $f
1323 or return; 1514 or return;
1515
1324 local $cf::PLAYER_LOADING{$login} = $pl; 1516 local $cf::PLAYER_LOADING{$login} = $pl;
1325 $f->resolve_delayed_derefs; 1517 $f->resolve_delayed_derefs;
1326 $cf::PLAYER{$login} = $pl 1518 $cf::PLAYER{$login} = $pl
1327 } 1519 }
1328 } 1520 }
… …
1338 1530
1339 return if $pl->{deny_save}; 1531 return if $pl->{deny_save};
1340 1532
1341 aio_mkdir playerdir $pl, 0770; 1533 aio_mkdir playerdir $pl, 0770;
1342 $pl->{last_save} = $cf::RUNTIME; 1534 $pl->{last_save} = $cf::RUNTIME;
1535
1536 cf::get_slot 0.01;
1343 1537
1344 $pl->save_pl ($path); 1538 $pl->save_pl ($path);
1345 cf::cede_to_tick; 1539 cf::cede_to_tick;
1346} 1540}
1347 1541
… …
1379 my ($pl) = @_; 1573 my ($pl) = @_;
1380 1574
1381 my $name = $pl->ob->name; 1575 my $name = $pl->ob->name;
1382 1576
1383 $pl->{deny_save} = 1; 1577 $pl->{deny_save} = 1;
1384 $pl->password ("*"); # this should lock out the player until we nuked the dir 1578 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1385 1579
1386 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1580 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1387 $pl->deactivate; 1581 $pl->deactivate;
1582 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1583 $pl->ob->check_score;
1388 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1584 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1389 $pl->ns->destroy if $pl->ns; 1585 $pl->ns->destroy if $pl->ns;
1390 1586
1391 my $path = playerdir $pl; 1587 my $path = playerdir $pl;
1392 my $temp = "$path~$cf::RUNTIME~deleting~"; 1588 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1431 1627
1432 for my $login (@$dirs) { 1628 for my $login (@$dirs) {
1433 my $path = path $login; 1629 my $path = path $login;
1434 1630
1435 # a .pst is a dead give-away for a valid player 1631 # a .pst is a dead give-away for a valid player
1436 unless (-e "$path.pst") { 1632 # if no pst file found, open and chekc for blocked users
1633 if (aio_stat "$path.pst") {
1437 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1634 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1438 aio_read $fh, 0, 512, my $buf, 0 or next; 1635 aio_read $fh, 0, 512, my $buf, 0 or next;
1439 $buf !~ /^password -------------$/m or next; # official not-valid tag 1636 $buf !~ /^password -------------$/m or next; # official not-valid tag
1440 } 1637 }
1441 1638
… …
1472 } 1669 }
1473 1670
1474 \@paths 1671 \@paths
1475} 1672}
1476 1673
1477=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1674=item $protocol_xml = $player->expand_cfpod ($cfpod)
1478 1675
1479Expand crossfire pod fragments into protocol xml. 1676Expand deliantra pod fragments into protocol xml.
1480
1481=cut
1482
1483sub expand_cfpod {
1484 ((my $self), (local $_)) = @_;
1485
1486 # escape & and <
1487 s/&/&amp;/g;
1488 s/(?<![BIUGHT])</&lt;/g;
1489
1490 # this is buggy, it needs to properly take care of nested <'s
1491
1492 1 while
1493 # replace B<>, I<>, U<> etc.
1494 s/B<([^\>]*)>/<b>$1<\/b>/
1495 || s/I<([^\>]*)>/<i>$1<\/i>/
1496 || s/U<([^\>]*)>/<u>$1<\/u>/
1497 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1498 # replace G<male|female> tags
1499 || s{G<([^>|]*)\|([^>]*)>}{
1500 $self->gender ? $2 : $1
1501 }ge
1502 # replace H<hint text>
1503 || s{H<([^\>]*)>}
1504 {
1505 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1506 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1507 "")
1508 [$self->{hintmode}]
1509 }ge;
1510
1511 # create single paragraphs (very hackish)
1512 s/(?<=\S)\n(?=\w)/ /g;
1513
1514 # compress some whitespace
1515 s/\s+\n/\n/g; # ws line-ends
1516 s/\n\n+/\n/g; # double lines
1517 s/^\n+//; # beginning lines
1518 s/\n+$//; # ending lines
1519
1520 $_
1521}
1522
1523sub hintmode {
1524 $_[0]{hintmode} = $_[1] if @_ > 1;
1525 $_[0]{hintmode}
1526}
1527 1677
1528=item $player->ext_reply ($msgid, @msg) 1678=item $player->ext_reply ($msgid, @msg)
1529 1679
1530Sends an ext reply to the player. 1680Sends an ext reply to the player.
1531 1681
… …
1598our $MAX_RESET = 3600; 1748our $MAX_RESET = 3600;
1599our $DEFAULT_RESET = 3000; 1749our $DEFAULT_RESET = 3000;
1600 1750
1601sub generate_random_map { 1751sub generate_random_map {
1602 my ($self, $rmp) = @_; 1752 my ($self, $rmp) = @_;
1753
1754 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1755
1603 # mit "rum" bekleckern, nicht 1756 # mit "rum" bekleckern, nicht
1604 $self->_create_random_map ( 1757 $self->_create_random_map (
1605 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1758 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1606 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1759 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1607 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1760 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1729 1882
1730# the temporary/swap location 1883# the temporary/swap location
1731sub save_path { 1884sub save_path {
1732 my ($self) = @_; 1885 my ($self) = @_;
1733 1886
1734 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1887 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1735 "$TMPDIR/$path.map" 1888 "$TMPDIR/$path.map"
1736} 1889}
1737 1890
1738# the unique path, undef == no special unique path 1891# the unique path, undef == no special unique path
1739sub uniq_path { 1892sub uniq_path {
1740 my ($self) = @_; 1893 my ($self) = @_;
1741 1894
1742 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1895 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1743 "$UNIQUEDIR/$path" 1896 "$UNIQUEDIR/$path"
1744}
1745
1746# and all this just because we cannot iterate over
1747# all maps in C++...
1748sub change_all_map_light {
1749 my ($change) = @_;
1750
1751 $_->change_map_light ($change)
1752 for grep $_->outdoor, values %cf::MAP;
1753} 1897}
1754 1898
1755sub decay_objects { 1899sub decay_objects {
1756 my ($self) = @_; 1900 my ($self) = @_;
1757 1901
… …
1841sub find { 1985sub find {
1842 my ($path, $origin) = @_; 1986 my ($path, $origin) = @_;
1843 1987
1844 $path = normalise $path, $origin && $origin->path; 1988 $path = normalise $path, $origin && $origin->path;
1845 1989
1990 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1846 cf::lock_wait "map_find:$path"; 1991 my $guard2 = cf::lock_acquire "map_find:$path";
1847 1992
1848 $cf::MAP{$path} || do { 1993 $cf::MAP{$path} || do {
1849 my $guard = cf::lock_acquire "map_find:$path";
1850 my $map = new_from_path cf::map $path 1994 my $map = new_from_path cf::map $path
1851 or return; 1995 or return;
1852 1996
1853 $map->{last_save} = $cf::RUNTIME; 1997 $map->{last_save} = $cf::RUNTIME;
1854 1998
… …
1856 or return; 2000 or return;
1857 2001
1858 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2002 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1859 # doing this can freeze the server in a sync job, obviously 2003 # doing this can freeze the server in a sync job, obviously
1860 #$cf::WAIT_FOR_TICK->wait; 2004 #$cf::WAIT_FOR_TICK->wait;
2005 undef $guard2;
2006 undef $guard1;
1861 $map->reset; 2007 $map->reset;
1862 undef $guard;
1863 return find $path; 2008 return find $path;
1864 } 2009 }
1865 2010
1866 $cf::MAP{$path} = $map 2011 $cf::MAP{$path} = $map
1867 } 2012 }
… …
1876 local $self->{deny_reset} = 1; # loading can take a long time 2021 local $self->{deny_reset} = 1; # loading can take a long time
1877 2022
1878 my $path = $self->{path}; 2023 my $path = $self->{path};
1879 2024
1880 { 2025 {
1881 my $guard1 = cf::lock_acquire "map_data:$path"; 2026 my $guard = cf::lock_acquire "map_data:$path";
1882 my $guard2 = cf::lock_acquire "map_load:$path";
1883 2027
2028 return unless $self->valid;
1884 return if $self->in_memory != cf::MAP_SWAPPED; 2029 return unless $self->in_memory == cf::MAP_SWAPPED;
1885 2030
1886 $self->in_memory (cf::MAP_LOADING); 2031 $self->in_memory (cf::MAP_LOADING);
1887 2032
1888 $self->alloc; 2033 $self->alloc;
1889 2034
… …
1893 my $f = new_from_file cf::object::thawer $self->{load_path}; 2038 my $f = new_from_file cf::object::thawer $self->{load_path};
1894 $f->skip_block; 2039 $f->skip_block;
1895 $self->_load_objects ($f) 2040 $self->_load_objects ($f)
1896 or return; 2041 or return;
1897 2042
1898 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2043 $self->post_load_original
1899 if delete $self->{load_original}; 2044 if delete $self->{load_original};
1900 2045
1901 if (my $uniq = $self->uniq_path) { 2046 if (my $uniq = $self->uniq_path) {
1902 utf8::encode $uniq; 2047 utf8::encode $uniq;
1903 unless (aio_stat $uniq) { 2048 unless (aio_stat $uniq) {
… …
1921 unless ($self->{deny_activate}) { 2066 unless ($self->{deny_activate}) {
1922 $self->decay_objects; 2067 $self->decay_objects;
1923 $self->fix_auto_apply; 2068 $self->fix_auto_apply;
1924 $self->update_buttons; 2069 $self->update_buttons;
1925 cf::cede_to_tick; 2070 cf::cede_to_tick;
1926 $self->set_darkness_map;
1927 cf::cede_to_tick;
1928 $self->activate; 2071 $self->activate;
1929 } 2072 }
1930 2073
1931 $self->{last_save} = $cf::RUNTIME; 2074 $self->{last_save} = $cf::RUNTIME;
1932 $self->last_access ($cf::RUNTIME); 2075 $self->last_access ($cf::RUNTIME);
1933 2076
1934 $self->in_memory (cf::MAP_IN_MEMORY); 2077 $self->in_memory (cf::MAP_ACTIVE);
1935 } 2078 }
1936 2079
1937 $self->post_load; 2080 $self->post_load;
1938} 2081}
1939 2082
… …
1997 my ($path, $origin, $load) = @_; 2140 my ($path, $origin, $load) = @_;
1998 2141
1999 $path = normalise $path, $origin && $origin->{path}; 2142 $path = normalise $path, $origin && $origin->{path};
2000 2143
2001 if (my $map = $cf::MAP{$path}) { 2144 if (my $map = $cf::MAP{$path}) {
2002 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2145 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2003 } 2146 }
2004 2147
2005 $MAP_PREFETCH{$path} |= $load; 2148 $MAP_PREFETCH{$path} |= $load;
2006 2149
2007 $MAP_PREFETCHER ||= cf::async { 2150 $MAP_PREFETCHER ||= cf::async {
2151 $Coro::current->{desc} = "map prefetcher";
2152
2008 while (%MAP_PREFETCH) { 2153 while (%MAP_PREFETCH) {
2009 while (my ($k, $v) = each %MAP_PREFETCH) { 2154 while (my ($k, $v) = each %MAP_PREFETCH) {
2010 if (my $map = find $k) { 2155 if (my $map = find $k) {
2011 $map->load if $v; 2156 $map->load if $v;
2012 } 2157 }
… …
2038 return if $self->{deny_save}; 2183 return if $self->{deny_save};
2039 2184
2040 local $self->{last_access} = $self->last_access;#d# 2185 local $self->{last_access} = $self->last_access;#d#
2041 2186
2042 cf::async { 2187 cf::async {
2188 $Coro::current->{desc} = "map player save";
2043 $_->contr->save for $self->players; 2189 $_->contr->save for $self->players;
2044 }; 2190 };
2191
2192 cf::get_slot 0.02;
2045 2193
2046 if ($uniq) { 2194 if ($uniq) {
2047 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2195 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2048 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2196 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2049 } else { 2197 } else {
… …
2058 $self->save; 2206 $self->save;
2059 2207
2060 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2208 my $lock = cf::lock_acquire "map_data:$self->{path}";
2061 2209
2062 return if $self->players; 2210 return if $self->players;
2063 return if $self->in_memory != cf::MAP_IN_MEMORY; 2211 return if $self->in_memory != cf::MAP_ACTIVE;
2064 return if $self->{deny_save}; 2212 return if $self->{deny_save};
2065 2213
2214 $self->in_memory (cf::MAP_SWAPPED);
2215
2216 $self->deactivate;
2217 $_->clear_links_to ($self) for values %cf::MAP;
2066 $self->clear; 2218 $self->clear;
2067 $self->in_memory (cf::MAP_SWAPPED);
2068} 2219}
2069 2220
2070sub reset_at { 2221sub reset_at {
2071 my ($self) = @_; 2222 my ($self) = @_;
2072 2223
… …
2090 2241
2091 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2242 my $lock = cf::lock_acquire "map_data:$self->{path}";
2092 2243
2093 return if $self->players; 2244 return if $self->players;
2094 2245
2095 warn "resetting map ", $self->path; 2246 warn "resetting map ", $self->path, "\n";
2096 2247
2097 $self->in_memory (cf::MAP_SWAPPED); 2248 $self->in_memory (cf::MAP_SWAPPED);
2098 2249
2099 # need to save uniques path 2250 # need to save uniques path
2100 unless ($self->{deny_save}) { 2251 unless ($self->{deny_save}) {
… …
2104 if $uniq; 2255 if $uniq;
2105 } 2256 }
2106 2257
2107 delete $cf::MAP{$self->path}; 2258 delete $cf::MAP{$self->path};
2108 2259
2260 $self->deactivate;
2261 $_->clear_links_to ($self) for values %cf::MAP;
2109 $self->clear; 2262 $self->clear;
2110
2111 $_->clear_links_to ($self) for values %cf::MAP;
2112 2263
2113 $self->unlink_save; 2264 $self->unlink_save;
2114 $self->destroy; 2265 $self->destroy;
2115} 2266}
2116 2267
… …
2183 2334
2184sub unique_maps() { 2335sub unique_maps() {
2185 [ 2336 [
2186 map { 2337 map {
2187 utf8::decode $_; 2338 utf8::decode $_;
2188 /\.map$/ 2339 s/\.map$//; # TODO future compatibility hack
2340 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2341 ? ()
2189 ? normalise $_ 2342 : normalise $_
2190 : ()
2191 } @{ aio_readdir $UNIQUEDIR or [] } 2343 } @{ aio_readdir $UNIQUEDIR or [] }
2192 ] 2344 ]
2193} 2345}
2194 2346
2195package cf; 2347=item cf::map::static_maps
2348
2349Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2350file in the shared directory excluding F</styles> and F</editor>). May
2351block.
2352
2353=cut
2354
2355sub static_maps() {
2356 my @dirs = "";
2357 my @maps;
2358
2359 while (@dirs) {
2360 my $dir = shift @dirs;
2361
2362 next if $dir eq "/styles" || $dir eq "/editor";
2363
2364 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2365 or return;
2366
2367 for (@$files) {
2368 s/\.map$// or next;
2369 utf8::decode $_;
2370 push @maps, "$dir/$_";
2371 }
2372
2373 push @dirs, map "$dir/$_", @$dirs;
2374 }
2375
2376 \@maps
2377}
2196 2378
2197=back 2379=back
2198 2380
2199=head3 cf::object 2381=head3 cf::object
2200 2382
… …
2204 2386
2205=over 4 2387=over 4
2206 2388
2207=item $ob->inv_recursive 2389=item $ob->inv_recursive
2208 2390
2209Returns the inventory of the object _and_ their inventories, recursively. 2391Returns the inventory of the object I<and> their inventories, recursively,
2392but I<not> the object itself.
2210 2393
2211=cut 2394=cut
2212 2395
2213sub inv_recursive_; 2396sub inv_recursive_;
2214sub inv_recursive_ { 2397sub inv_recursive_ {
… …
2219 inv_recursive_ inv $_[0] 2402 inv_recursive_ inv $_[0]
2220} 2403}
2221 2404
2222=item $ref = $ob->ref 2405=item $ref = $ob->ref
2223 2406
2224creates and returns a persistent reference to an objetc that can be stored as a string. 2407Creates and returns a persistent reference to an object that can be stored as a string.
2225 2408
2226=item $ob = cf::object::deref ($refstring) 2409=item $ob = cf::object::deref ($refstring)
2227 2410
2228returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2411returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2229even if the object actually exists. May block. 2412even if the object actually exists. May block.
… …
2231=cut 2414=cut
2232 2415
2233sub deref { 2416sub deref {
2234 my ($ref) = @_; 2417 my ($ref) = @_;
2235 2418
2236 # temporary compatibility#TODO#remove
2237 $ref =~ s{^<}{player/<};
2238
2239 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) { 2419 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2240 my ($uuid, $name) = ($1, $2); 2420 my ($uuid, $name) = ($1, $2);
2241 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name 2421 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2242 or return; 2422 or return;
2243 $pl->ob->uuid eq $uuid 2423 $pl->ob->uuid eq $uuid
2244 or return; 2424 or return;
… …
2264can be C<undef>. Does the right thing when the player is currently in a 2444can be C<undef>. Does the right thing when the player is currently in a
2265dialogue with the given NPC character. 2445dialogue with the given NPC character.
2266 2446
2267=cut 2447=cut
2268 2448
2449our $SAY_CHANNEL = {
2450 id => "say",
2451 title => "Map",
2452 reply => "say ",
2453 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2454};
2455
2456our $CHAT_CHANNEL = {
2457 id => "chat",
2458 title => "Chat",
2459 reply => "chat ",
2460 tooltip => "Player chat and shouts, global to the server.",
2461};
2462
2269# rough implementation of a future "reply" method that works 2463# rough implementation of a future "reply" method that works
2270# with dialog boxes. 2464# with dialog boxes.
2271#TODO: the first argument must go, split into a $npc->reply_to ( method 2465#TODO: the first argument must go, split into a $npc->reply_to ( method
2272sub cf::object::player::reply($$$;$) { 2466sub cf::object::player::reply($$$;$) {
2273 my ($self, $npc, $msg, $flags) = @_; 2467 my ($self, $npc, $msg, $flags) = @_;
… …
2284 my $dialog = $pl->{npc_dialog}; 2478 my $dialog = $pl->{npc_dialog};
2285 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2479 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2286 2480
2287 } else { 2481 } else {
2288 $msg = $npc->name . " says: $msg" if $npc; 2482 $msg = $npc->name . " says: $msg" if $npc;
2289 $self->message ($msg, $flags); 2483 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2290 } 2484 }
2291 } 2485 }
2292} 2486}
2293 2487
2294=item $object->send_msg ($channel, $msg, $color, [extra...]) 2488=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2319 2513
2320=item $player_object->enter_link 2514=item $player_object->enter_link
2321 2515
2322Freezes the player and moves him/her to a special map (C<{link}>). 2516Freezes the player and moves him/her to a special map (C<{link}>).
2323 2517
2324The player should be reasonably safe there for short amounts of time. You 2518The player should be reasonably safe there for short amounts of time (e.g.
2325I<MUST> call C<leave_link> as soon as possible, though. 2519for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2520though, as the palyer cannot control the character while it is on the link
2521map.
2326 2522
2327Will never block. 2523Will never block.
2328 2524
2329=item $player_object->leave_link ($map, $x, $y) 2525=item $player_object->leave_link ($map, $x, $y)
2330 2526
… …
2382 ($x, $y) = (-1, -1) 2578 ($x, $y) = (-1, -1)
2383 unless (defined $x) && (defined $y); 2579 unless (defined $x) && (defined $y);
2384 2580
2385 # use -1 or undef as default coordinates, not 0, 0 2581 # use -1 or undef as default coordinates, not 0, 0
2386 ($x, $y) = ($map->enter_x, $map->enter_y) 2582 ($x, $y) = ($map->enter_x, $map->enter_y)
2387 if $x <=0 && $y <= 0; 2583 if $x <= 0 && $y <= 0;
2388 2584
2389 $map->load; 2585 $map->load;
2390 $map->load_neighbours; 2586 $map->load_neighbours;
2391 2587
2392 return unless $self->contr->active; 2588 return unless $self->contr->active;
2393 $self->activate_recursive;
2394 2589
2395 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2590 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2396 $self->enter_map ($map, $x, $y); 2591 $self->enter_map ($map, $x, $y);
2592
2593 # only activate afterwards, to support waiting in hooks
2594 $self->activate_recursive;
2397} 2595}
2398 2596
2399=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2597=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2400 2598
2401Moves the player to the given map-path and coordinates by first freezing 2599Moves the player to the given map-path and coordinates by first freezing
2402her, loading and preparing them map, calling the provided $check callback 2600her, loading and preparing them map, calling the provided $check callback
2403that has to return the map if sucecssful, and then unfreezes the player on 2601that has to return the map if sucecssful, and then unfreezes the player on
2404the new (success) or old (failed) map position. In either case, $done will 2602the new (success) or old (failed) map position. In either case, $done will
2405be called at the end of this process. 2603be called at the end of this process.
2406 2604
2605Note that $check will be called with a potentially non-loaded map, so if
2606it needs a loaded map it has to call C<< ->load >>.
2607
2407=cut 2608=cut
2408 2609
2409our $GOTOGEN; 2610our $GOTOGEN;
2410 2611
2411sub cf::object::player::goto { 2612sub cf::object::player::goto {
… …
2415 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2616 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2416 2617
2417 $self->enter_link; 2618 $self->enter_link;
2418 2619
2419 (async { 2620 (async {
2621 $Coro::current->{desc} = "player::goto $path $x $y";
2622
2623 # *tag paths override both path and x|y
2624 if ($path =~ /^\*(.*)$/) {
2625 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2626 my $ob = $obs[rand @obs];
2627
2628 # see if we actually can go there
2629 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2630 $ob = $obs[rand @obs];
2631 } else {
2632 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2633 }
2634 # else put us there anyways for now #d#
2635
2636 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2637 } else {
2638 ($path, $x, $y) = (undef, undef, undef);
2639 }
2640 }
2641
2420 my $map = eval { 2642 my $map = eval {
2421 my $map = cf::map::find $path; 2643 my $map = defined $path ? cf::map::find $path : undef;
2422 2644
2423 if ($map) { 2645 if ($map) {
2424 $map = $map->customise_for ($self); 2646 $map = $map->customise_for ($self);
2425 $map = $check->($map) if $check && $map; 2647 $map = $check->($map) if $check && $map;
2426 } else { 2648 } else {
2427 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2649 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2428 } 2650 }
2429 2651
2430 $map 2652 $map
2431 }; 2653 };
2432 2654
… …
2468} 2690}
2469 2691
2470sub prepare_random_map { 2692sub prepare_random_map {
2471 my ($exit) = @_; 2693 my ($exit) = @_;
2472 2694
2473 my $guard = cf::lock_acquire "exit_prepare:$exit";
2474
2475 # all this does is basically replace the /! path by 2695 # all this does is basically replace the /! path by
2476 # a new random map path (?random/...) with a seed 2696 # a new random map path (?random/...) with a seed
2477 # that depends on the exit object 2697 # that depends on the exit object
2478 2698
2479 my $rmp = parse_random_map_params $exit->msg; 2699 my $rmp = parse_random_map_params $exit->msg;
… …
2481 if ($exit->map) { 2701 if ($exit->map) {
2482 $rmp->{region} = $exit->region->name; 2702 $rmp->{region} = $exit->region->name;
2483 $rmp->{origin_map} = $exit->map->path; 2703 $rmp->{origin_map} = $exit->map->path;
2484 $rmp->{origin_x} = $exit->x; 2704 $rmp->{origin_x} = $exit->x;
2485 $rmp->{origin_y} = $exit->y; 2705 $rmp->{origin_y} = $exit->y;
2706
2707 $exit->map->touch;
2486 } 2708 }
2487 2709
2488 $rmp->{random_seed} ||= $exit->random_seed; 2710 $rmp->{random_seed} ||= $exit->random_seed;
2489 2711
2490 my $data = cf::to_json $rmp; 2712 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2491 my $md5 = Digest::MD5::md5_hex $data; 2713 my $md5 = Digest::MD5::md5_hex $data;
2492 my $meta = "$RANDOMDIR/$md5.meta"; 2714 my $meta = "$RANDOMDIR/$md5.meta";
2493 2715
2494 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2716 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2495 aio_write $fh, 0, (length $data), $data, 0; 2717 aio_write $fh, 0, (length $data), $data, 0;
2496 undef $fh; 2718 undef $fh;
2497 aio_rename "$meta~", $meta; 2719 aio_rename "$meta~", $meta;
2498 2720
2721 my $slaying = "?random/$md5";
2722
2723 if ($exit->valid) {
2499 $exit->slaying ("?random/$md5"); 2724 $exit->slaying ("?random/$md5");
2500 $exit->msg (undef); 2725 $exit->msg (undef);
2726 }
2501 } 2727 }
2502} 2728}
2503 2729
2504sub cf::object::player::enter_exit { 2730sub cf::object::player::enter_exit {
2505 my ($self, $exit) = @_; 2731 my ($self, $exit) = @_;
2506 2732
2507 return unless $self->type == cf::PLAYER; 2733 return unless $self->type == cf::PLAYER;
2508 2734
2509 if ($exit->slaying eq "/!") {
2510 #TODO: this should de-fi-ni-te-ly not be a sync-job
2511 # the problem is that $exit might not survive long enough
2512 # so it needs to be done right now, right here
2513 cf::sync_job { prepare_random_map $exit };
2514 }
2515
2516 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2517 my $hp = $exit->stats->hp;
2518 my $sp = $exit->stats->sp;
2519
2520 $self->enter_link; 2735 $self->enter_link;
2521 2736
2522 # if exit is damned, update players death & WoR home-position
2523 $self->contr->savebed ($slaying, $hp, $sp)
2524 if $exit->flag (FLAG_DAMNED);
2525
2526 (async { 2737 (async {
2527 $self->deactivate_recursive; # just to be sure 2738 $Coro::current->{desc} = "enter_exit";
2739
2528 unless (eval { 2740 unless (eval {
2741 $self->deactivate_recursive; # just to be sure
2742
2743 # random map handling
2744 {
2745 my $guard = cf::lock_acquire "exit_prepare:$exit";
2746
2747 prepare_random_map $exit
2748 if $exit->slaying eq "/!";
2749 }
2750
2751 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2752 my $x = $exit->stats->hp;
2753 my $y = $exit->stats->sp;
2754
2529 $self->goto ($slaying, $hp, $sp); 2755 $self->goto ($map, $x, $y);
2530 2756
2757 # if exit is damned, update players death & WoR home-position
2758 $self->contr->savebed ($map, $x, $y)
2759 if $exit->flag (cf::FLAG_DAMNED);
2760
2531 1; 2761 1
2532 }) { 2762 }) {
2533 $self->message ("Something went wrong deep within the crossfire server. " 2763 $self->message ("Something went wrong deep within the deliantra server. "
2534 . "I'll try to bring you back to the map you were before. " 2764 . "I'll try to bring you back to the map you were before. "
2535 . "Please report this to the dungeon master!", 2765 . "Please report this to the dungeon master!",
2536 cf::NDI_UNIQUE | cf::NDI_RED); 2766 cf::NDI_UNIQUE | cf::NDI_RED);
2537 2767
2538 warn "ERROR in enter_exit: $@"; 2768 warn "ERROR in enter_exit: $@";
… …
2566the message, with C<log> being the default. If C<$color> is negative, suppress 2796the message, with C<log> being the default. If C<$color> is negative, suppress
2567the message unless the client supports the msg packet. 2797the message unless the client supports the msg packet.
2568 2798
2569=cut 2799=cut
2570 2800
2801# non-persistent channels (usually the info channel)
2571our %CHANNEL = ( 2802our %CHANNEL = (
2803 "c/motd" => {
2804 id => "infobox",
2805 title => "MOTD",
2806 reply => undef,
2807 tooltip => "The message of the day",
2808 },
2572 "c/identify" => { 2809 "c/identify" => {
2573 id => "identify", 2810 id => "infobox",
2574 title => "Identify", 2811 title => "Identify",
2575 reply => undef, 2812 reply => undef,
2576 tooltip => "Items recently identified", 2813 tooltip => "Items recently identified",
2577 }, 2814 },
2578 "c/examine" => { 2815 "c/examine" => {
2579 id => "examine", 2816 id => "infobox",
2580 title => "Examine", 2817 title => "Examine",
2581 reply => undef, 2818 reply => undef,
2582 tooltip => "Signs and other items you examined", 2819 tooltip => "Signs and other items you examined",
2583 }, 2820 },
2821 "c/shopinfo" => {
2822 id => "infobox",
2823 title => "Shop Info",
2824 reply => undef,
2825 tooltip => "What your bargaining skill tells you about the shop",
2826 },
2827 "c/book" => {
2828 id => "infobox",
2829 title => "Book",
2830 reply => undef,
2831 tooltip => "The contents of a note or book",
2832 },
2833 "c/lookat" => {
2834 id => "infobox",
2835 title => "Look",
2836 reply => undef,
2837 tooltip => "What you saw there",
2838 },
2839 "c/who" => {
2840 id => "infobox",
2841 title => "Players",
2842 reply => undef,
2843 tooltip => "Shows players who are currently online",
2844 },
2845 "c/body" => {
2846 id => "infobox",
2847 title => "Body Parts",
2848 reply => undef,
2849 tooltip => "Shows which body parts you posess and are available",
2850 },
2851 "c/statistics" => {
2852 id => "infobox",
2853 title => "Statistics",
2854 reply => undef,
2855 tooltip => "Shows your primary statistics",
2856 },
2857 "c/skills" => {
2858 id => "infobox",
2859 title => "Skills",
2860 reply => undef,
2861 tooltip => "Shows your experience per skill and item power",
2862 },
2863 "c/shopitems" => {
2864 id => "infobox",
2865 title => "Shop Items",
2866 reply => undef,
2867 tooltip => "Shows the items currently for sale in this shop",
2868 },
2869 "c/resistances" => {
2870 id => "infobox",
2871 title => "Resistances",
2872 reply => undef,
2873 tooltip => "Shows your resistances",
2874 },
2875 "c/pets" => {
2876 id => "infobox",
2877 title => "Pets",
2878 reply => undef,
2879 tooltip => "Shows information abotu your pets/a specific pet",
2880 },
2881 "c/perceiveself" => {
2882 id => "infobox",
2883 title => "Perceive Self",
2884 reply => undef,
2885 tooltip => "You gained detailed knowledge about yourself",
2886 },
2887 "c/uptime" => {
2888 id => "infobox",
2889 title => "Uptime",
2890 reply => undef,
2891 tooltip => "How long the server has been running since last restart",
2892 },
2893 "c/mapinfo" => {
2894 id => "infobox",
2895 title => "Map Info",
2896 reply => undef,
2897 tooltip => "Information related to the maps",
2898 },
2899 "c/party" => {
2900 id => "party",
2901 title => "Party",
2902 reply => "gsay ",
2903 tooltip => "Messages and chat related to your party",
2904 },
2905 "c/death" => {
2906 id => "death",
2907 title => "Death",
2908 reply => undef,
2909 tooltip => "Reason for and more info about your most recent death",
2910 },
2911 "c/say" => $SAY_CHANNEL,
2912 "c/chat" => $CHAT_CHANNEL,
2584); 2913);
2585 2914
2586sub cf::client::send_msg { 2915sub cf::client::send_msg {
2587 my ($self, $channel, $msg, $color, @extra) = @_; 2916 my ($self, $channel, $msg, $color, @extra) = @_;
2588 2917
2589 $msg = $self->pl->expand_cfpod ($msg); 2918 $msg = $self->pl->expand_cfpod ($msg)
2919 unless $color & cf::NDI_VERBATIM;
2590 2920
2591 $color &= cf::NDI_CLIENT_MASK; # just in case... 2921 $color &= cf::NDI_CLIENT_MASK; # just in case...
2592 2922
2593 # check predefined channels, for the benefit of C 2923 # check predefined channels, for the benefit of C
2594 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2924 if ($CHANNEL{$channel}) {
2925 $channel = $CHANNEL{$channel};
2595 2926
2927 $self->ext_msg (channel_info => $channel);
2928 $channel = $channel->{id};
2929
2596 if (ref $channel) { 2930 } elsif (ref $channel) {
2597 # send meta info to client, if not yet sent 2931 # send meta info to client, if not yet sent
2598 unless (exists $self->{channel}{$channel->{id}}) { 2932 unless (exists $self->{channel}{$channel->{id}}) {
2599 $self->{channel}{$channel->{id}} = $channel; 2933 $self->{channel}{$channel->{id}} = $channel;
2600 $self->ext_msg (channel_info => $channel) 2934 $self->ext_msg (channel_info => $channel);
2601 if $self->can_msg;
2602 } 2935 }
2603 2936
2604 $channel = $channel->{id}; 2937 $channel = $channel->{id};
2605 } 2938 }
2606 2939
2607 return unless @extra || length $msg; 2940 return unless @extra || length $msg;
2608 2941
2609 if ($self->can_msg) {
2610 # default colour, mask it out 2942 # default colour, mask it out
2611 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2943 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2612 if $color & cf::NDI_DEF; 2944 if $color & cf::NDI_DEF;
2613 2945
2614 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2946 my $pkt = "msg "
2947 . $self->{json_coder}->encode (
2615 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2948 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2616 } else { 2949 );
2617 if ($color >= 0) {
2618 # replace some tags by gcfclient-compatible ones
2619 for ($msg) {
2620 1 while
2621 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2622 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2623 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2624 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2625 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2626 }
2627 2950
2628 $color &= cf::NDI_COLOR_MASK; 2951 # try lzf for large packets
2952 $pkt = "lzf " . Compress::LZF::compress $pkt
2953 if 1024 <= length $pkt and $self->{can_lzf};
2629 2954
2630 utf8::encode $msg; 2955 # split very large packets
2631 2956 if (8192 < length $pkt and $self->{can_lzf}) {
2632 if (0 && $msg =~ /\[/) { 2957 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2633 # COMMAND/INFO 2958 $pkt = "frag";
2634 $self->send_packet ("drawextinfo $color 10 8 $msg")
2635 } else {
2636 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2637 $self->send_packet ("drawinfo $color $msg")
2638 }
2639 }
2640 } 2959 }
2960
2961 $self->send_packet ($pkt);
2641} 2962}
2642 2963
2643=item $client->ext_msg ($type, @msg) 2964=item $client->ext_msg ($type, @msg)
2644 2965
2645Sends an ext event to the client. 2966Sends an ext event to the client.
… …
2818=pod 3139=pod
2819 3140
2820The following functions and methods are available within a safe environment: 3141The following functions and methods are available within a safe environment:
2821 3142
2822 cf::object 3143 cf::object
2823 contr pay_amount pay_player map x y force_find force_add 3144 contr pay_amount pay_player map x y force_find force_add destroy
2824 insert remove name archname title slaying race decrease_ob_nr 3145 insert remove name archname title slaying race decrease split
3146 value
2825 3147
2826 cf::object::player 3148 cf::object::player
2827 player 3149 player
2828 3150
2829 cf::player 3151 cf::player
… …
2834 3156
2835=cut 3157=cut
2836 3158
2837for ( 3159for (
2838 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3160 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2839 insert remove inv name archname title slaying race 3161 insert remove inv nrof name archname title slaying race
2840 decrease_ob_nr)], 3162 decrease split destroy change_exp value msg lore send_msg)],
2841 ["cf::object::player" => qw(player)], 3163 ["cf::object::player" => qw(player)],
2842 ["cf::player" => qw(peaceful)], 3164 ["cf::player" => qw(peaceful send_msg)],
2843 ["cf::map" => qw(trigger)], 3165 ["cf::map" => qw(trigger)],
2844) { 3166) {
2845 no strict 'refs'; 3167 no strict 'refs';
2846 my ($pkg, @funs) = @$_; 3168 my ($pkg, @funs) = @$_;
2847 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3169 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
2864 my ($code, %vars) = @_; 3186 my ($code, %vars) = @_;
2865 3187
2866 my $qcode = $code; 3188 my $qcode = $code;
2867 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3189 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2868 $qcode =~ s/\n/\\n/g; 3190 $qcode =~ s/\n/\\n/g;
3191
3192 %vars = (_dummy => 0) unless %vars;
2869 3193
2870 local $_; 3194 local $_;
2871 local @safe::cf::_safe_eval_args = values %vars; 3195 local @safe::cf::_safe_eval_args = values %vars;
2872 3196
2873 my $eval = 3197 my $eval =
… …
2950 { 3274 {
2951 my $faces = $facedata->{faceinfo}; 3275 my $faces = $facedata->{faceinfo};
2952 3276
2953 while (my ($face, $info) = each %$faces) { 3277 while (my ($face, $info) = each %$faces) {
2954 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3278 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3279
2955 cf::face::set_visibility $idx, $info->{visibility}; 3280 cf::face::set_visibility $idx, $info->{visibility};
2956 cf::face::set_magicmap $idx, $info->{magicmap}; 3281 cf::face::set_magicmap $idx, $info->{magicmap};
2957 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3282 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2958 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3283 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2959 3284
2960 cf::cede_to_tick; 3285 cf::cede_to_tick;
2961 } 3286 }
2962 3287
2963 while (my ($face, $info) = each %$faces) { 3288 while (my ($face, $info) = each %$faces) {
2964 next unless $info->{smooth}; 3289 next unless $info->{smooth};
3290
2965 my $idx = cf::face::find $face 3291 my $idx = cf::face::find $face
2966 or next; 3292 or next;
3293
2967 if (my $smooth = cf::face::find $info->{smooth}) { 3294 if (my $smooth = cf::face::find $info->{smooth}) {
2968 cf::face::set_smooth $idx, $smooth; 3295 cf::face::set_smooth $idx, $smooth;
2969 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3296 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2970 } else { 3297 } else {
2971 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3298 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2989 { 3316 {
2990 # TODO: for gcfclient pleasure, we should give resources 3317 # TODO: for gcfclient pleasure, we should give resources
2991 # that gcfclient doesn't grok a >10000 face index. 3318 # that gcfclient doesn't grok a >10000 face index.
2992 my $res = $facedata->{resource}; 3319 my $res = $facedata->{resource};
2993 3320
2994 my $soundconf = delete $res->{"res/sound.conf"};
2995
2996 while (my ($name, $info) = each %$res) { 3321 while (my ($name, $info) = each %$res) {
3322 if (defined $info->{type}) {
2997 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3323 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2998 my $data; 3324 my $data;
2999 3325
3000 if ($info->{type} & 1) { 3326 if ($info->{type} & 1) {
3001 # prepend meta info 3327 # prepend meta info
3002 3328
3003 my $meta = $enc->encode ({ 3329 my $meta = $enc->encode ({
3004 name => $name, 3330 name => $name,
3005 %{ $info->{meta} || {} }, 3331 %{ $info->{meta} || {} },
3006 }); 3332 });
3007 3333
3008 $data = pack "(w/a*)*", $meta, $info->{data}; 3334 $data = pack "(w/a*)*", $meta, $info->{data};
3335 } else {
3336 $data = $info->{data};
3337 }
3338
3339 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3340 cf::face::set_type $idx, $info->{type};
3009 } else { 3341 } else {
3010 $data = $info->{data}; 3342 $RESOURCE{$name} = $info;
3011 } 3343 }
3012 3344
3013 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3014 cf::face::set_type $idx, $info->{type};
3015
3016 cf::cede_to_tick; 3345 cf::cede_to_tick;
3017 } 3346 }
3018
3019 if ($soundconf) {
3020 $soundconf = $enc->decode (delete $soundconf->{data});
3021
3022 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3023 my $sound = $soundconf->{compat}[$_]
3024 or next;
3025
3026 my $face = cf::face::find "sound/$sound->[1]";
3027 cf::sound::set $sound->[0] => $face;
3028 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3029 }
3030
3031 while (my ($k, $v) = each %{$soundconf->{event}}) {
3032 my $face = cf::face::find "sound/$v";
3033 cf::sound::set $k => $face;
3034 }
3035 }
3036 } 3347 }
3348
3349 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3037 3350
3038 1 3351 1
3039} 3352}
3353
3354cf::global->attach (on_resource_update => sub {
3355 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3356 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3357
3358 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3359 my $sound = $soundconf->{compat}[$_]
3360 or next;
3361
3362 my $face = cf::face::find "sound/$sound->[1]";
3363 cf::sound::set $sound->[0] => $face;
3364 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3365 }
3366
3367 while (my ($k, $v) = each %{$soundconf->{event}}) {
3368 my $face = cf::face::find "sound/$v";
3369 cf::sound::set $k => $face;
3370 }
3371 }
3372});
3040 3373
3041register_exticmd fx_want => sub { 3374register_exticmd fx_want => sub {
3042 my ($ns, $want) = @_; 3375 my ($ns, $want) = @_;
3043 3376
3044 while (my ($k, $v) = each %$want) { 3377 while (my ($k, $v) = each %$want) {
3045 $ns->fx_want ($k, $v); 3378 $ns->fx_want ($k, $v);
3046 } 3379 }
3047}; 3380};
3381
3382sub load_resource_file($) {
3383 my $guard = lock_acquire "load_resource_file";
3384
3385 my $status = load_resource_file_ $_[0];
3386 get_slot 0.1, 100;
3387 cf::arch::commit_load;
3388
3389 $status
3390}
3048 3391
3049sub reload_regions { 3392sub reload_regions {
3050 # HACK to clear player env face cache, we need some signal framework 3393 # HACK to clear player env face cache, we need some signal framework
3051 # for this (global event?) 3394 # for this (global event?)
3052 %ext::player_env::MUSIC_FACE_CACHE = (); 3395 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3066} 3409}
3067 3410
3068sub reload_archetypes { 3411sub reload_archetypes {
3069 load_resource_file "$DATADIR/archetypes" 3412 load_resource_file "$DATADIR/archetypes"
3070 or die "unable to load archetypes\n"; 3413 or die "unable to load archetypes\n";
3071 #d# NEED to laod twice to resolve forward references
3072 # this really needs to be done in an extra post-pass
3073 # (which needs to be synchronous, so solve it differently)
3074 load_resource_file "$DATADIR/archetypes"
3075 or die "unable to load archetypes\n";
3076} 3414}
3077 3415
3078sub reload_treasures { 3416sub reload_treasures {
3079 load_resource_file "$DATADIR/treasures" 3417 load_resource_file "$DATADIR/treasures"
3080 or die "unable to load treasurelists\n"; 3418 or die "unable to load treasurelists\n";
3081} 3419}
3082 3420
3083sub reload_resources { 3421sub reload_resources {
3084 warn "reloading resource files...\n"; 3422 warn "reloading resource files...\n";
3085 3423
3424 reload_facedata;
3425 reload_archetypes;
3086 reload_regions; 3426 reload_regions;
3087 reload_facedata;
3088 #reload_archetypes;#d#
3089 reload_archetypes;
3090 reload_treasures; 3427 reload_treasures;
3091 3428
3092 warn "finished reloading resource files\n"; 3429 warn "finished reloading resource files\n";
3093} 3430}
3094 3431
3095sub init {
3096 reload_resources;
3097}
3098
3099sub reload_config { 3432sub reload_config {
3433 warn "reloading config file...\n";
3434
3100 open my $fh, "<:utf8", "$CONFDIR/config" 3435 open my $fh, "<:utf8", "$CONFDIR/config"
3101 or return; 3436 or return;
3102 3437
3103 local $/; 3438 local $/;
3104 *CFG = YAML::Syck::Load <$fh>; 3439 *CFG = YAML::XS::Load scalar <$fh>;
3105 3440
3106 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3441 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3107 3442
3108 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3443 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3109 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3444 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3113 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3448 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3114 and die "WARNING: m(un)lockall failed: $!\n"; 3449 and die "WARNING: m(un)lockall failed: $!\n";
3115 }; 3450 };
3116 warn $@ if $@; 3451 warn $@ if $@;
3117 } 3452 }
3453
3454 warn "finished reloading resource files\n";
3455}
3456
3457sub pidfile() {
3458 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3459 or die "$PIDFILE: $!";
3460 flock $fh, &Fcntl::LOCK_EX
3461 or die "$PIDFILE: flock: $!";
3462 $fh
3463}
3464
3465# make sure only one server instance is running at any one time
3466sub atomic {
3467 my $fh = pidfile;
3468
3469 my $pid = <$fh>;
3470 kill 9, $pid if $pid > 0;
3471
3472 seek $fh, 0, 0;
3473 print $fh $$;
3474}
3475
3476sub main_loop {
3477 warn "EV::loop starting\n";
3478 if (1) {
3479 EV::loop;
3480 }
3481 warn "EV::loop returned\n";
3482 goto &main_loop unless $REALLY_UNLOOP;
3118} 3483}
3119 3484
3120sub main { 3485sub main {
3486 cf::init_globals; # initialise logging
3487
3488 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3489 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3490 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3491 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3492
3493 cf::init_experience;
3494 cf::init_anim;
3495 cf::init_attackmess;
3496 cf::init_dynamic;
3497
3498 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3499
3121 # we must not ever block the main coroutine 3500 # we must not ever block the main coroutine
3122 local $Coro::idle = sub { 3501 local $Coro::idle = sub {
3123 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3502 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3124 (async { 3503 (async {
3125 Event::one_event; 3504 $Coro::current->{desc} = "IDLE BUG HANDLER";
3505 EV::loop EV::LOOP_ONESHOT;
3126 })->prio (Coro::PRIO_MAX); 3506 })->prio (Coro::PRIO_MAX);
3127 }; 3507 };
3128 3508
3509 evthread_start IO::AIO::poll_fileno;
3510
3511 cf::sync_job {
3512 reload_resources;
3129 reload_config; 3513 reload_config;
3130 db_init; 3514 db_init;
3515
3516 cf::load_settings;
3517 cf::load_materials;
3518 cf::init_uuid;
3519 cf::init_signals;
3520 cf::init_commands;
3521 cf::init_skills;
3522
3523 cf::init_beforeplay;
3524
3525 atomic;
3526
3131 load_extensions; 3527 load_extensions;
3132 3528
3133 $TICK_WATCHER->start; 3529 utime time, time, $RUNTIMEFILE;
3134 Event::loop; 3530
3531 # no (long-running) fork's whatsoever before this point(!)
3532 use POSIX ();
3533 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3534
3535 (pop @POST_INIT)->(0) while @POST_INIT;
3536 };
3537
3538 main_loop;
3135} 3539}
3136 3540
3137############################################################################# 3541#############################################################################
3138# initialisation and cleanup 3542# initialisation and cleanup
3139 3543
3140# install some emergency cleanup handlers 3544# install some emergency cleanup handlers
3141BEGIN { 3545BEGIN {
3546 our %SIGWATCHER = ();
3142 for my $signal (qw(INT HUP TERM)) { 3547 for my $signal (qw(INT HUP TERM)) {
3143 Event->signal ( 3548 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3144 reentrant => 0,
3145 data => WF_AUTOCANCEL,
3146 signal => $signal,
3147 prio => 0,
3148 cb => sub {
3149 cf::cleanup "SIG$signal"; 3549 cf::cleanup "SIG$signal";
3150 },
3151 ); 3550 };
3152 } 3551 }
3153} 3552}
3154 3553
3155sub write_runtime { 3554sub write_runtime_sync {
3156 my $runtime = "$LOCALDIR/runtime";
3157
3158 # first touch the runtime file to show we are still running: 3555 # first touch the runtime file to show we are still running:
3159 # the fsync below can take a very very long time. 3556 # the fsync below can take a very very long time.
3160 3557
3161 IO::AIO::aio_utime $runtime, undef, undef; 3558 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3162 3559
3163 my $guard = cf::lock_acquire "write_runtime"; 3560 my $guard = cf::lock_acquire "write_runtime";
3164 3561
3165 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3562 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3166 or return; 3563 or return;
3167 3564
3168 my $value = $cf::RUNTIME + 90 + 10; 3565 my $value = $cf::RUNTIME + 90 + 10;
3169 # 10 is the runtime save interval, for a monotonic clock 3566 # 10 is the runtime save interval, for a monotonic clock
3170 # 60 allows for the watchdog to kill the server. 3567 # 60 allows for the watchdog to kill the server.
… …
3180 aio_utime $fh, undef, undef; 3577 aio_utime $fh, undef, undef;
3181 3578
3182 close $fh 3579 close $fh
3183 or return; 3580 or return;
3184 3581
3185 aio_rename "$runtime~", $runtime 3582 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3186 and return; 3583 and return;
3187 3584
3188 warn "runtime file written.\n"; 3585 warn "runtime file written.\n";
3189 3586
3190 1 3587 1
3588}
3589
3590our $uuid_lock;
3591our $uuid_skip;
3592
3593sub write_uuid_sync($) {
3594 $uuid_skip ||= $_[0];
3595
3596 return if $uuid_lock;
3597 local $uuid_lock = 1;
3598
3599 my $uuid = "$LOCALDIR/uuid";
3600
3601 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3602 or return;
3603
3604 my $value = uuid_seq uuid_cur;
3605
3606 unless ($value) {
3607 warn "cowardly refusing to write zero uuid value!\n";
3608 return;
3609 }
3610
3611 my $value = uuid_str $value + $uuid_skip;
3612 $uuid_skip = 0;
3613
3614 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3615 and return;
3616
3617 # always fsync - this file is important
3618 aio_fsync $fh
3619 and return;
3620
3621 close $fh
3622 or return;
3623
3624 aio_rename "$uuid~", $uuid
3625 and return;
3626
3627 warn "uuid file written ($value).\n";
3628
3629 1
3630
3631}
3632
3633sub write_uuid($$) {
3634 my ($skip, $sync) = @_;
3635
3636 $sync ? write_uuid_sync $skip
3637 : async { write_uuid_sync $skip };
3191} 3638}
3192 3639
3193sub emergency_save() { 3640sub emergency_save() {
3194 my $freeze_guard = cf::freeze_mainloop; 3641 my $freeze_guard = cf::freeze_mainloop;
3195 3642
3196 warn "enter emergency perl save\n"; 3643 warn "emergency_perl_save: enter\n";
3197 3644
3198 cf::sync_job { 3645 cf::sync_job {
3646 # this is a trade-off: we want to be very quick here, so
3647 # save all maps without fsync, and later call a global sync
3648 # (which in turn might be very very slow)
3649 local $USE_FSYNC = 0;
3650
3199 # use a peculiar iteration method to avoid tripping on perl 3651 # use a peculiar iteration method to avoid tripping on perl
3200 # refcount bugs in for. also avoids problems with players 3652 # refcount bugs in for. also avoids problems with players
3201 # and maps saved/destroyed asynchronously. 3653 # and maps saved/destroyed asynchronously.
3202 warn "begin emergency player save\n"; 3654 warn "emergency_perl_save: begin player save\n";
3203 for my $login (keys %cf::PLAYER) { 3655 for my $login (keys %cf::PLAYER) {
3204 my $pl = $cf::PLAYER{$login} or next; 3656 my $pl = $cf::PLAYER{$login} or next;
3205 $pl->valid or next; 3657 $pl->valid or next;
3658 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3206 $pl->save; 3659 $pl->save;
3207 } 3660 }
3208 warn "end emergency player save\n"; 3661 warn "emergency_perl_save: end player save\n";
3209 3662
3210 warn "begin emergency map save\n"; 3663 warn "emergency_perl_save: begin map save\n";
3211 for my $path (keys %cf::MAP) { 3664 for my $path (keys %cf::MAP) {
3212 my $map = $cf::MAP{$path} or next; 3665 my $map = $cf::MAP{$path} or next;
3213 $map->valid or next; 3666 $map->valid or next;
3214 $map->save; 3667 $map->save;
3215 } 3668 }
3216 warn "end emergency map save\n"; 3669 warn "emergency_perl_save: end map save\n";
3217 3670
3218 warn "begin emergency database checkpoint\n"; 3671 warn "emergency_perl_save: begin database checkpoint\n";
3219 BDB::db_env_txn_checkpoint $DB_ENV; 3672 BDB::db_env_txn_checkpoint $DB_ENV;
3220 warn "end emergency database checkpoint\n"; 3673 warn "emergency_perl_save: end database checkpoint\n";
3674
3675 warn "emergency_perl_save: begin write uuid\n";
3676 write_uuid_sync 1;
3677 warn "emergency_perl_save: end write uuid\n";
3221 }; 3678 };
3222 3679
3680 warn "emergency_perl_save: starting sync()\n";
3681 IO::AIO::aio_sync sub {
3682 warn "emergency_perl_save: finished sync()\n";
3683 };
3684
3223 warn "leave emergency perl save\n"; 3685 warn "emergency_perl_save: leave\n";
3224} 3686}
3225 3687
3226sub post_cleanup { 3688sub post_cleanup {
3227 my ($make_core) = @_; 3689 my ($make_core) = @_;
3228 3690
3229 warn Carp::longmess "post_cleanup backtrace" 3691 warn Carp::longmess "post_cleanup backtrace"
3230 if $make_core; 3692 if $make_core;
3693
3694 my $fh = pidfile;
3695 unlink $PIDFILE if <$fh> == $$;
3696}
3697
3698# a safer delete_package, copied from Symbol
3699sub clear_package($) {
3700 my $pkg = shift;
3701
3702 # expand to full symbol table name if needed
3703 unless ($pkg =~ /^main::.*::$/) {
3704 $pkg = "main$pkg" if $pkg =~ /^::/;
3705 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3706 $pkg .= '::' unless $pkg =~ /::$/;
3707 }
3708
3709 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3710 my $stem_symtab = *{$stem}{HASH};
3711
3712 defined $stem_symtab and exists $stem_symtab->{$leaf}
3713 or return;
3714
3715 # clear all symbols
3716 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3717 for my $name (keys %$leaf_symtab) {
3718 _gv_clear *{"$pkg$name"};
3719# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3720 }
3721 warn "cleared package $pkg\n";#d#
3231} 3722}
3232 3723
3233sub do_reload_perl() { 3724sub do_reload_perl() {
3234 # can/must only be called in main 3725 # can/must only be called in main
3235 if ($Coro::current != $Coro::main) { 3726 if ($Coro::current != $Coro::main) {
3236 warn "can only reload from main coroutine"; 3727 warn "can only reload from main coroutine";
3237 return; 3728 return;
3238 } 3729 }
3239 3730
3731 return if $RELOAD++;
3732
3733 my $t1 = EV::time;
3734
3735 while ($RELOAD) {
3240 warn "reloading..."; 3736 warn "reloading...";
3241 3737
3242 warn "entering sync_job"; 3738 warn "entering sync_job";
3243 3739
3244 cf::sync_job { 3740 cf::sync_job {
3245 cf::write_runtime; # external watchdog should not bark 3741 cf::write_runtime_sync; # external watchdog should not bark
3246 cf::emergency_save; 3742 cf::emergency_save;
3247 cf::write_runtime; # external watchdog should not bark 3743 cf::write_runtime_sync; # external watchdog should not bark
3248 3744
3249 warn "syncing database to disk"; 3745 warn "syncing database to disk";
3250 BDB::db_env_txn_checkpoint $DB_ENV; 3746 BDB::db_env_txn_checkpoint $DB_ENV;
3251 3747
3252 # if anything goes wrong in here, we should simply crash as we already saved 3748 # if anything goes wrong in here, we should simply crash as we already saved
3253 3749
3254 warn "cancelling all WF_AUTOCANCEL watchers";
3255 for (Event::all_watchers) {
3256 $_->cancel if $_->data & WF_AUTOCANCEL;
3257 }
3258
3259 warn "flushing outstanding aio requests"; 3750 warn "flushing outstanding aio requests";
3260 for (;;) {
3261 BDB::flush;
3262 IO::AIO::flush;
3263 Coro::cede;
3264 last unless IO::AIO::nreqs || BDB::nreqs; 3751 while (IO::AIO::nreqs || BDB::nreqs) {
3265 warn "iterate..."; 3752 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3266 }
3267
3268 ++$RELOAD;
3269
3270 warn "cancelling all extension coros";
3271 $_->cancel for values %EXT_CORO;
3272 %EXT_CORO = ();
3273
3274 warn "removing commands";
3275 %COMMAND = ();
3276
3277 warn "removing ext/exti commands";
3278 %EXTCMD = ();
3279 %EXTICMD = ();
3280
3281 warn "unloading/nuking all extensions";
3282 for my $pkg (@EXTS) {
3283 warn "... unloading $pkg";
3284
3285 if (my $cb = $pkg->can ("unload")) {
3286 eval {
3287 $cb->($pkg);
3288 1
3289 } or warn "$pkg unloaded, but with errors: $@";
3290 } 3753 }
3291 3754
3292 warn "... nuking $pkg"; 3755 warn "cancelling all extension coros";
3293 Symbol::delete_package $pkg; 3756 $_->cancel for values %EXT_CORO;
3294 } 3757 %EXT_CORO = ();
3295 3758
3296 warn "unloading all perl modules loaded from $LIBDIR"; 3759 warn "removing commands";
3297 while (my ($k, $v) = each %INC) { 3760 %COMMAND = ();
3298 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3299 3761
3762 warn "removing ext/exti commands";
3763 %EXTCMD = ();
3764 %EXTICMD = ();
3765
3766 warn "unloading/nuking all extensions";
3767 for my $pkg (@EXTS) {
3300 warn "... unloading $k"; 3768 warn "... unloading $pkg";
3301 delete $INC{$k};
3302 3769
3303 $k =~ s/\.pm$//;
3304 $k =~ s/\//::/g;
3305
3306 if (my $cb = $k->can ("unload_module")) { 3770 if (my $cb = $pkg->can ("unload")) {
3771 eval {
3307 $cb->(); 3772 $cb->($pkg);
3773 1
3774 } or warn "$pkg unloaded, but with errors: $@";
3775 }
3776
3777 warn "... clearing $pkg";
3778 clear_package $pkg;
3308 } 3779 }
3309 3780
3310 Symbol::delete_package $k; 3781 warn "unloading all perl modules loaded from $LIBDIR";
3782 while (my ($k, $v) = each %INC) {
3783 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3784
3785 warn "... unloading $k";
3786 delete $INC{$k};
3787
3788 $k =~ s/\.pm$//;
3789 $k =~ s/\//::/g;
3790
3791 if (my $cb = $k->can ("unload_module")) {
3792 $cb->();
3793 }
3794
3795 clear_package $k;
3311 } 3796 }
3312 3797
3313 warn "getting rid of safe::, as good as possible"; 3798 warn "getting rid of safe::, as good as possible";
3314 Symbol::delete_package "safe::$_" 3799 clear_package "safe::$_"
3315 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3800 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3316 3801
3317 warn "unloading cf.pm \"a bit\""; 3802 warn "unloading cf.pm \"a bit\"";
3318 delete $INC{"cf.pm"}; 3803 delete $INC{"cf.pm"};
3319 delete $INC{"cf/pod.pm"}; 3804 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3320 3805
3321 # don't, removes xs symbols, too, 3806 # don't, removes xs symbols, too,
3322 # and global variables created in xs 3807 # and global variables created in xs
3323 #Symbol::delete_package __PACKAGE__; 3808 #clear_package __PACKAGE__;
3324 3809
3325 warn "unload completed, starting to reload now"; 3810 warn "unload completed, starting to reload now";
3326 3811
3327 warn "reloading cf.pm"; 3812 warn "reloading cf.pm";
3328 require cf; 3813 require cf;
3329 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3814 cf::_connect_to_perl_1;
3330 3815
3331 warn "loading config and database again"; 3816 warn "loading config and database again";
3332 cf::reload_config; 3817 cf::reload_config;
3333 3818
3334 warn "loading extensions"; 3819 warn "loading extensions";
3335 cf::load_extensions; 3820 cf::load_extensions;
3336 3821
3822 if ($REATTACH_ON_RELOAD) {
3337 warn "reattaching attachments to objects/players"; 3823 warn "reattaching attachments to objects/players";
3338 _global_reattach; # objects, sockets 3824 _global_reattach; # objects, sockets
3339 warn "reattaching attachments to maps"; 3825 warn "reattaching attachments to maps";
3340 reattach $_ for values %MAP; 3826 reattach $_ for values %MAP;
3341 warn "reattaching attachments to players"; 3827 warn "reattaching attachments to players";
3342 reattach $_ for values %PLAYER; 3828 reattach $_ for values %PLAYER;
3829 }
3343 3830
3831 warn "running post_init jobs";
3832 (pop @POST_INIT)->(1) while @POST_INIT;
3833
3344 warn "leaving sync_job"; 3834 warn "leaving sync_job";
3345 3835
3346 1 3836 1
3347 } or do { 3837 } or do {
3348 warn $@; 3838 warn $@;
3349 warn "error while reloading, exiting."; 3839 cf::cleanup "error while reloading, exiting.";
3350 exit 1;
3351 }; 3840 };
3352 3841
3353 warn "reloaded"; 3842 warn "reloaded";
3843 --$RELOAD;
3844 }
3845
3846 $t1 = EV::time - $t1;
3847 warn "reload completed in ${t1}s\n";
3354}; 3848};
3355 3849
3356our $RELOAD_WATCHER; # used only during reload 3850our $RELOAD_WATCHER; # used only during reload
3357 3851
3358sub reload_perl() { 3852sub reload_perl() {
3359 # doing reload synchronously and two reloads happen back-to-back, 3853 # doing reload synchronously and two reloads happen back-to-back,
3360 # coro crashes during coro_state_free->destroy here. 3854 # coro crashes during coro_state_free->destroy here.
3361 3855
3362 $RELOAD_WATCHER ||= Event->timer ( 3856 $RELOAD_WATCHER ||= cf::async {
3363 reentrant => 0, 3857 Coro::AIO::aio_wait cache_extensions;
3364 after => 0, 3858
3365 data => WF_AUTOCANCEL, 3859 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3366 cb => sub {
3367 do_reload_perl; 3860 do_reload_perl;
3368 undef $RELOAD_WATCHER; 3861 undef $RELOAD_WATCHER;
3369 }, 3862 };
3370 ); 3863 };
3371} 3864}
3372 3865
3373register_command "reload" => sub { 3866register_command "reload" => sub {
3374 my ($who, $arg) = @_; 3867 my ($who, $arg) = @_;
3375 3868
3376 if ($who->flag (FLAG_WIZ)) { 3869 if ($who->flag (FLAG_WIZ)) {
3377 $who->message ("reloading server."); 3870 $who->message ("reloading server.");
3871 async {
3872 $Coro::current->{desc} = "perl_reload";
3378 async { reload_perl }; 3873 reload_perl;
3874 };
3379 } 3875 }
3380}; 3876};
3381 3877
3382unshift @INC, $LIBDIR; 3878unshift @INC, $LIBDIR;
3383 3879
… …
3385 3881
3386our @WAIT_FOR_TICK; 3882our @WAIT_FOR_TICK;
3387our @WAIT_FOR_TICK_BEGIN; 3883our @WAIT_FOR_TICK_BEGIN;
3388 3884
3389sub wait_for_tick { 3885sub wait_for_tick {
3390 return unless $TICK_WATCHER->is_active;
3391 return if $Coro::current == $Coro::main; 3886 return if tick_inhibit || $Coro::current == $Coro::main;
3392 3887
3393 my $signal = new Coro::Signal; 3888 my $signal = new Coro::Signal;
3394 push @WAIT_FOR_TICK, $signal; 3889 push @WAIT_FOR_TICK, $signal;
3395 $signal->wait; 3890 $signal->wait;
3396} 3891}
3397 3892
3398sub wait_for_tick_begin { 3893sub wait_for_tick_begin {
3399 return unless $TICK_WATCHER->is_active;
3400 return if $Coro::current == $Coro::main; 3894 return if tick_inhibit || $Coro::current == $Coro::main;
3401 3895
3402 my $signal = new Coro::Signal; 3896 my $signal = new Coro::Signal;
3403 push @WAIT_FOR_TICK_BEGIN, $signal; 3897 push @WAIT_FOR_TICK_BEGIN, $signal;
3404 $signal->wait; 3898 $signal->wait;
3405} 3899}
3406 3900
3407 my $min = 1e6;#d# 3901sub tick {
3408 my $avg = 10;
3409$TICK_WATCHER = Event->timer (
3410 reentrant => 0,
3411 parked => 1,
3412 prio => 0,
3413 at => $NEXT_TICK || $TICK,
3414 data => WF_AUTOCANCEL,
3415 cb => sub {
3416 if ($Coro::current != $Coro::main) { 3902 if ($Coro::current != $Coro::main) {
3417 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3903 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3418 unless ++$bug_warning > 10; 3904 unless ++$bug_warning > 10;
3419 return; 3905 return;
3420 } 3906 }
3421 3907
3422 $NOW = $tick_start = Event::time;
3423
3424 cf::server_tick; # one server iteration 3908 cf::server_tick; # one server iteration
3425 3909
3426 0 && sync_job {#d# 3910 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3427 for(1..10) { 3911 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3428 my $t = Event::time; 3912 Coro::async_pool {
3429 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3913 $Coro::current->{desc} = "runtime saver";
3430 or die; 3914 write_runtime_sync
3431 3915 or warn "ERROR: unable to write runtime file: $!";
3432 $map->width (50);
3433 $map->height (50);
3434 $map->alloc;
3435 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
3436 my $t = Event::time - $t;
3437
3438 #next unless $t < 0.0013;#d#
3439 if ($t < $min) {
3440 $min = $t;
3441 }
3442 $avg = $avg * 0.99 + $t * 0.01;
3443 }
3444 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3445 exit 0;
3446 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3447 }; 3916 };
3917 }
3448 3918
3449 $RUNTIME += $TICK;
3450 $NEXT_TICK += $TICK;
3451
3452 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3453 $NEXT_RUNTIME_WRITE = $NOW + 10;
3454 Coro::async_pool {
3455 write_runtime
3456 or warn "ERROR: unable to write runtime file: $!";
3457 };
3458 }
3459
3460# my $AFTER = Event::time;
3461# warn $AFTER - $NOW;#d#
3462
3463 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3919 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3464 $sig->send; 3920 $sig->send;
3465 } 3921 }
3466 while (my $sig = shift @WAIT_FOR_TICK) { 3922 while (my $sig = shift @WAIT_FOR_TICK) {
3467 $sig->send; 3923 $sig->send;
3468 } 3924 }
3469 3925
3470 $NOW = Event::time; 3926 $LOAD = ($NOW - $TICK_START) / $TICK;
3471
3472 # if we are delayed by four ticks or more, skip them all
3473 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3474
3475 $TICK_WATCHER->at ($NEXT_TICK);
3476 $TICK_WATCHER->start;
3477
3478 $LOAD = ($NOW - $tick_start) / $TICK;
3479 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3927 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3480 3928
3481 _post_tick; 3929 if (0) {
3482 3930 if ($NEXT_TICK) {
3483 3931 my $jitter = $TICK_START - $NEXT_TICK;
3932 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3933 warn "jitter $JITTER\n";#d#
3934 }
3484 }, 3935 }
3485); 3936}
3486 3937
3487{ 3938{
3488 BDB::max_poll_time $TICK * 0.1; 3939 # configure BDB
3489 $BDB_POLL_WATCHER = Event->io ( 3940
3490 reentrant => 0,
3491 fd => BDB::poll_fileno,
3492 poll => 'r',
3493 prio => 0,
3494 data => WF_AUTOCANCEL,
3495 cb => \&BDB::poll_cb,
3496 );
3497 BDB::min_parallel 8; 3941 BDB::min_parallel 8;
3498 3942 BDB::max_poll_reqs $TICK * 0.1;
3499 BDB::set_sync_prepare { 3943 $AnyEvent::BDB::WATCHER->priority (1);
3500 my $status;
3501 my $current = $Coro::current;
3502 (
3503 sub {
3504 $status = $!;
3505 $current->ready; undef $current;
3506 },
3507 sub {
3508 Coro::schedule while defined $current;
3509 $! = $status;
3510 },
3511 )
3512 };
3513 3944
3514 unless ($DB_ENV) { 3945 unless ($DB_ENV) {
3515 $DB_ENV = BDB::db_env_create; 3946 $DB_ENV = BDB::db_env_create;
3947 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3948 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3949 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3950 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3951 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3516 3952
3517 cf::sync_job { 3953 cf::sync_job {
3518 eval { 3954 eval {
3519 BDB::db_env_open 3955 BDB::db_env_open
3520 $DB_ENV, 3956 $DB_ENV,
… …
3522 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3958 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3523 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3959 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3524 0666; 3960 0666;
3525 3961
3526 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3962 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3527
3528 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3529 $DB_ENV->set_lk_detect;
3530 }; 3963 };
3531 3964
3532 cf::cleanup "db_env_open(db): $@" if $@; 3965 cf::cleanup "db_env_open(db): $@" if $@;
3533 }; 3966 };
3534 } 3967 }
3968
3969 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3970 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3971 };
3972 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3973 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3974 };
3975 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3976 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3977 };
3535} 3978}
3536 3979
3537{ 3980{
3981 # configure IO::AIO
3982
3538 IO::AIO::min_parallel 8; 3983 IO::AIO::min_parallel 8;
3539
3540 undef $Coro::AIO::WATCHER;
3541 IO::AIO::max_poll_time $TICK * 0.1; 3984 IO::AIO::max_poll_time $TICK * 0.1;
3542 $AIO_POLL_WATCHER = Event->io ( 3985 undef $AnyEvent::AIO::WATCHER;
3543 reentrant => 0,
3544 data => WF_AUTOCANCEL,
3545 fd => IO::AIO::poll_fileno,
3546 poll => 'r',
3547 prio => 6,
3548 cb => \&IO::AIO::poll_cb,
3549 );
3550} 3986}
3551 3987
3552my $_log_backtrace; 3988my $_log_backtrace;
3553 3989
3554sub _log_backtrace { 3990sub _log_backtrace {
… …
3557 $msg =~ s/\n//; 3993 $msg =~ s/\n//;
3558 3994
3559 # limit the # of concurrent backtraces 3995 # limit the # of concurrent backtraces
3560 if ($_log_backtrace < 2) { 3996 if ($_log_backtrace < 2) {
3561 ++$_log_backtrace; 3997 ++$_log_backtrace;
3998 my $perl_bt = Carp::longmess $msg;
3562 async { 3999 async {
4000 $Coro::current->{desc} = "abt $msg";
4001
3563 my @bt = fork_call { 4002 my @bt = fork_call {
3564 @addr = map { sprintf "%x", $_ } @addr; 4003 @addr = map { sprintf "%x", $_ } @addr;
3565 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 4004 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3566 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 4005 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3567 or die "addr2line: $!"; 4006 or die "addr2line: $!";
… …
3575 } 4014 }
3576 4015
3577 @funcs 4016 @funcs
3578 }; 4017 };
3579 4018
3580 LOG llevInfo, "[ABT] $msg\n"; 4019 LOG llevInfo, "[ABT] $perl_bt\n";
4020 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3581 LOG llevInfo, "[ABT] $_\n" for @bt; 4021 LOG llevInfo, "[ABT] $_\n" for @bt;
3582 --$_log_backtrace; 4022 --$_log_backtrace;
3583 }; 4023 };
3584 } else { 4024 } else {
3585 LOG llevInfo, "[ABT] $msg\n"; 4025 LOG llevInfo, "[ABT] $msg\n";
3586 LOG llevInfo, "[ABT] [suppressed]\n"; 4026 LOG llevInfo, "[ABT] [suppressed]\n";
3587 } 4027 }
3588} 4028}
3589 4029
3590# load additional modules 4030# load additional modules
3591use cf::pod; 4031require "cf/$_.pm" for @EXTRA_MODULES;
4032cf::_connect_to_perl_2;
3592 4033
3593END { cf::emergency_save } 4034END { cf::emergency_save }
3594 4035
35951 40361
3596 4037

Diff Legend

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