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.275 by root, Thu Jun 7 19:12:22 2007 UTC vs.
Revision 1.495 by root, Tue Nov 10 04:38:45 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.61 (); 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;
53use Coro::Util ();
24 54
55use JSON::XS 2.01 ();
25use BDB (); 56use BDB ();
26use Data::Dumper; 57use Data::Dumper;
27use Digest::MD5; 58use Digest::MD5;
28use Fcntl; 59use Fcntl;
29use YAML::Syck (); 60use YAML::XS ();
30use IO::AIO 2.32 (); 61use IO::AIO ();
31use Time::HiRes; 62use Time::HiRes;
32use Compress::LZF; 63use Compress::LZF;
64use Digest::MD5 ();
65
66AnyEvent::detect;
33 67
34# configure various modules to our taste 68# configure various modules to our taste
35# 69#
36$Storable::canonical = 1; # reduce rsync transfers 70$Storable::canonical = 1; # reduce rsync transfers
37Coro::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";
38Compress::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
39 78
40$Event::Eval = 1; # no idea why this is required, but it is 79# strictly for debugging
41 80$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
43$YAML::Syck::ImplicitUnicode = 1;
44
45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46 81
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 82sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
48 83
49our %COMMAND = (); 84our %COMMAND = ();
50our %COMMAND_TIME = (); 85our %COMMAND_TIME = ();
51 86
52our @EXTS = (); # list of extension package names 87our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 88our %EXTCMD = ();
89our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 90our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 91our %EXT_MAP = (); # pluggable maps
56 92
57our $RELOAD; # number of reloads so far 93our $RELOAD; # number of reloads so far, non-zero while in reload
58our @EVENT; 94our @EVENT;
95our @REFLECT; # set by XS
96our %REFLECT; # set by us
59 97
60our $CONFDIR = confdir; 98our $CONFDIR = confdir;
61our $DATADIR = datadir; 99our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir; 103our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir; 104our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 105our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir; 106our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random"; 107our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db"; 108our $BDBDIR = "$LOCALDIR/db";
109our $PIDFILE = "$LOCALDIR/pid";
110our $RUNTIMEFILE = "$LOCALDIR/runtime";
111
112our %RESOURCE;
71 113
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 114our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 115our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
76our $NEXT_TICK; 116our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 117our $USE_FSYNC = 1; # use fsync to write maps - default on
79 118
119our $BDB_DEADLOCK_WATCHER;
120our $BDB_CHECKPOINT_WATCHER;
80our $BDB_POLL_WATCHER; 121our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 122our $DB_ENV;
123
124our @EXTRA_MODULES = qw(pod match mapscript);
82 125
83our %CFG; 126our %CFG;
84 127
85our $UPTIME; $UPTIME ||= time; 128our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 129our $RUNTIME;
130our $NOW;
87 131
88our %PLAYER; # all users 132our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 133our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 134our $LINK_MAP; # the special {link} map, which is always available
91 135
92# 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 ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 137our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 138
95our $LOAD; # a number between 0 (idle) and 1 (too many objects) 139our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing 140our $LOADAVG; # same thing, but with alpha-smoothing
141our $JITTER; # average jitter
97our $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 :)
98 148
99binmode STDOUT; 149binmode STDOUT;
100binmode STDERR; 150binmode STDERR;
101 151
102# read virtual server time, if available 152# read virtual server time, if available
103unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 153unless ($RUNTIME || !-e $RUNTIMEFILE) {
104 open my $fh, "<", "$LOCALDIR/runtime" 154 open my $fh, "<", $RUNTIMEFILE
105 or die "unable to read runtime file: $!"; 155 or die "unable to read $RUNTIMEFILE file: $!";
106 $RUNTIME = <$fh> + 0.; 156 $RUNTIME = <$fh> + 0.;
107} 157}
158
159eval "sub TICK() { $TICK } 1" or die;
108 160
109mkdir $_ 161mkdir $_
110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 162 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
111 163
112our $EMERGENCY_POSITION; 164our $EMERGENCY_POSITION;
113 165
114sub 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::"} };
115 178
116############################################################################# 179#############################################################################
117 180
118=head2 GLOBAL VARIABLES 181=head2 GLOBAL VARIABLES
119 182
… …
155 218
156The raw value load value from the last tick. 219The raw value load value from the last tick.
157 220
158=item %cf::CFG 221=item %cf::CFG
159 222
160Configuration for the server, loaded from C</etc/crossfire/config>, or 223Configuration for the server, loaded from C</etc/deliantra-server/config>, or
161from wherever your confdir points to. 224from wherever your confdir points to.
162 225
163=item cf::wait_for_tick, cf::wait_for_tick_begin 226=item cf::wait_for_tick, cf::wait_for_tick_begin
164 227
165These 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
166returns 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
167per 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.
168 231
232=item @cf::INVOKE_RESULTS
233
234This array contains the results of the last C<invoke ()> call. When
235C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
236that call.
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
169=back 244=back
170 245
171=cut 246=cut
172 247
173BEGIN { 248$Coro::State::WARNHOOK = sub {
174 *CORE::GLOBAL::warn = sub {
175 my $msg = join "", @_; 249 my $msg = join "", @_;
176 250
177 $msg .= "\n" 251 $msg .= "\n"
178 unless $msg =~ /\n$/; 252 unless $msg =~ /\n$/;
179 253
180 $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;
181 255
182 utf8::encode $msg;
183 LOG llevError, $msg; 256 LOG llevError, $msg;
184 }; 257};
185} 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};
186 272
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 273@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 274@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 275@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 276@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
197for my $pkg (qw( 283for my $pkg (qw(
198 cf::global cf::attachable 284 cf::global cf::attachable
199 cf::object cf::object::player 285 cf::object cf::object::player
200 cf::client cf::player 286 cf::client cf::player
201 cf::arch cf::living 287 cf::arch cf::living
288 cf::map cf::mapspace
202 cf::map cf::party cf::region 289 cf::party cf::region
203)) { 290)) {
204 no strict 'refs';
205 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 291 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
206} 292}
207 293
208$Event::DIED = sub { 294$EV::DIED = sub {
209 warn "error in event callback: @_"; 295 Carp::cluck "error in event callback: @_";
210}; 296};
297
298#############################################################################
211 299
212=head2 UTILITY FUNCTIONS 300=head2 UTILITY FUNCTIONS
213 301
214=over 4 302=over 4
215 303
… …
234 $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;
235 $d 323 $d
236 } || "[unable to dump $_[0]: '$@']"; 324 } || "[unable to dump $_[0]: '$@']";
237} 325}
238 326
239use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
240
241=item $ref = cf::from_json $json 327=item $ref = cf::decode_json $json
242 328
243Converts a JSON string into the corresponding perl data structure. 329Converts a JSON string into the corresponding perl data structure.
244 330
245=item $json = cf::to_json $ref 331=item $json = cf::encode_json $ref
246 332
247Converts a perl data structure into its JSON representation. 333Converts a perl data structure into its JSON representation.
248 334
335=cut
336
337our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
338
339sub encode_json($) { $json_coder->encode ($_[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}
355
249=item cf::lock_wait $string 356=item cf::lock_wait $string
250 357
251Wait until the given lock is available. See cf::lock_acquire. 358Wait until the given lock is available. See cf::lock_acquire.
252 359
253=item my $lock = cf::lock_acquire $string 360=item my $lock = cf::lock_acquire $string
254 361
255Wait 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
256a 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,
257for example when the coroutine gets canceled), the lock is automatically 364for example when the coroutine gets canceled), the lock is automatically
258returned. 365returned.
259 366
367Locks are *not* recursive, locking from the same coro twice results in a
368deadlocked coro.
369
260Lock names should begin with a unique identifier (for example, cf::map::find 370Lock names should begin with a unique identifier (for example, cf::map::find
261uses map_find and cf::map::load uses map_load). 371uses map_find and cf::map::load uses map_load).
262 372
263=item $locked = cf::lock_active $string 373=item $locked = cf::lock_active $string
264 374
265Return 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.
266 376
267=cut 377=cut
268 378
269our %LOCK; 379our $LOCKS = new Coro::SemaphoreSet;
270 380
271sub lock_wait($) { 381sub lock_wait($) {
272 my ($key) = @_; 382 $LOCKS->wait ($_[0]);
273
274 # wait for lock, if any
275 while ($LOCK{$key}) {
276 push @{ $LOCK{$key} }, $Coro::current;
277 Coro::schedule;
278 }
279} 383}
280 384
281sub lock_acquire($) { 385sub lock_acquire($) {
282 my ($key) = @_; 386 $LOCKS->guard ($_[0])
283
284 # wait, to be sure we are not locked
285 lock_wait $key;
286
287 $LOCK{$key} = [];
288
289 Coro::guard {
290 # wake up all waiters, to be on the safe side
291 $_->ready for @{ delete $LOCK{$key} };
292 }
293} 387}
294 388
295sub lock_active($) { 389sub lock_active($) {
296 my ($key) = @_; 390 $LOCKS->count ($_[0]) < 1
297
298 ! ! $LOCK{$key}
299} 391}
300 392
301sub freeze_mainloop { 393sub freeze_mainloop {
302 return unless $TICK_WATCHER->is_active; 394 tick_inhibit_inc;
303 395
304 my $guard = Coro::guard { 396 &Guard::guard (\&tick_inhibit_dec);
305 $TICK_WATCHER->start; 397}
398
399=item cf::periodic $interval, $cb
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
412}
413
414=item cf::get_slot $time[, $priority[, $name]]
415
416Allocate $time seconds of blocking CPU time at priority C<$priority>:
417This call blocks and returns only when you have at least C<$time> seconds
418of cpu time till the next tick. The slot is only valid till the next cede.
419
420The optional C<$name> can be used to identify the job to run. It might be
421used for statistical purposes and should identify the same time-class.
422
423Useful for short background jobs.
424
425=cut
426
427our @SLOT_QUEUE;
428our $SLOT_QUEUE;
429
430$SLOT_QUEUE->cancel if $SLOT_QUEUE;
431$SLOT_QUEUE = Coro::async {
432 $Coro::current->desc ("timeslot manager");
433
434 my $signal = new Coro::Signal;
435
436 while () {
437 next_job:
438 my $avail = cf::till_tick;
439 if ($avail > 0.01) {
440 for (0 .. $#SLOT_QUEUE) {
441 if ($SLOT_QUEUE[$_][0] < $avail) {
442 my $job = splice @SLOT_QUEUE, $_, 1, ();
443 $job->[2]->send;
444 Coro::cede;
445 goto next_job;
446 }
447 }
448 }
449
450 if (@SLOT_QUEUE) {
451 # we do not use wait_for_tick() as it returns immediately when tick is inactive
452 push @cf::WAIT_FOR_TICK, $signal;
453 $signal->wait;
454 } else {
455 Coro::schedule;
456 }
306 }; 457 }
307 $TICK_WATCHER->stop; 458};
308 $guard 459
460sub get_slot($;$$) {
461 return if tick_inhibit || $Coro::current == $Coro::main;
462
463 my ($time, $pri, $name) = @_;
464
465 $time = $TICK * .6 if $time > $TICK * .6;
466 my $sig = new Coro::Signal;
467
468 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
469 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
470 $SLOT_QUEUE->ready;
471 $sig->wait;
309} 472}
310 473
311=item cf::async { BLOCK } 474=item cf::async { BLOCK }
312 475
313Currently the same as Coro::async_pool, meaning you cannot use 476Currently the same as Coro::async_pool, meaning you cannot use
… …
318 481
319BEGIN { *async = \&Coro::async_pool } 482BEGIN { *async = \&Coro::async_pool }
320 483
321=item cf::sync_job { BLOCK } 484=item cf::sync_job { BLOCK }
322 485
323The design of crossfire+ requires that the main coro ($Coro::main) is 486The design of Deliantra requires that the main coroutine ($Coro::main)
324always able to handle events or runnable, as crossfire+ is only partly 487is always able to handle events or runnable, as Deliantra is only
325reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 488partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
489acceptable.
326 490
327If 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
328the given BLOCK in another coroutine while waiting for the result. The 492the given BLOCK in another coroutine while waiting for the result. The
329server will be frozen during this time, so the block should either finish 493server will be frozen during this time, so the block should either finish
330fast or be very important. 494fast or be very important.
… …
333 497
334sub sync_job(&) { 498sub sync_job(&) {
335 my ($job) = @_; 499 my ($job) = @_;
336 500
337 if ($Coro::current == $Coro::main) { 501 if ($Coro::current == $Coro::main) {
338 my $time = Event::time; 502 my $time = EV::time;
339 503
340 # this is the main coro, too bad, we have to block 504 # this is the main coro, too bad, we have to block
341 # till the operation succeeds, freezing the server :/ 505 # till the operation succeeds, freezing the server :/
342 506
343 # TODO: use suspend/resume instead 507 LOG llevError, Carp::longmess "sync job";#d#
344 # (but this is cancel-safe) 508
345 my $freeze_guard = freeze_mainloop; 509 my $freeze_guard = freeze_mainloop;
346 510
347 my $busy = 1; 511 my $busy = 1;
348 my @res; 512 my @res;
349 513
350 (async { 514 (async {
515 $Coro::current->desc ("sync job coro");
351 @res = eval { $job->() }; 516 @res = eval { $job->() };
352 warn $@ if $@; 517 warn $@ if $@;
353 undef $busy; 518 undef $busy;
354 })->prio (Coro::PRIO_MAX); 519 })->prio (Coro::PRIO_MAX);
355 520
356 while ($busy) { 521 while ($busy) {
357 Coro::cede or Event::one_event; 522 if (Coro::nready) {
523 Coro::cede_notself;
524 } else {
525 EV::loop EV::LOOP_ONESHOT;
358 } 526 }
527 }
359 528
360 $time = Event::time - $time; 529 my $time = EV::time - $time;
361 530
362 LOG llevError | logBacktrace, Carp::longmess "long sync job"
363 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
364
365 $tick_start += $time; # do not account sync jobs to server load 531 $TICK_START += $time; # do not account sync jobs to server load
366 532
367 wantarray ? @res : $res[0] 533 wantarray ? @res : $res[0]
368 } else { 534 } else {
369 # we are in another coroutine, how wonderful, everything just works 535 # we are in another coroutine, how wonderful, everything just works
370 536
… …
390 $EXT_CORO{$coro+0} = $coro; 556 $EXT_CORO{$coro+0} = $coro;
391 557
392 $coro 558 $coro
393} 559}
394 560
395sub write_runtime { 561=item fork_call { }, $args
396 my $runtime = "$LOCALDIR/runtime";
397 562
398 # first touch the runtime file to show we are still running: 563Executes the given code block with the given arguments in a seperate
399 # the fsync below can take a very very long time. 564process, returning the results. Everything must be serialisable with
565Coro::Storable. May, of course, block. Note that the executed sub may
566never block itself or use any form of event handling.
400 567
401 IO::AIO::aio_utime $runtime, undef, undef; 568=cut
402 569
403 my $guard = cf::lock_acquire "write_runtime"; 570sub fork_call(&@) {
571 my ($cb, @args) = @_;
404 572
405 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 573 # we seemingly have to make a local copy of the whole thing,
406 or return; 574 # otherwise perl prematurely frees the stuff :/
575 # TODO: investigate and fix (likely this will be rather laborious)
407 576
408 my $value = $cf::RUNTIME + 90 + 10; 577 my @res = Coro::Util::fork_eval {
409 # 10 is the runtime save interval, for a monotonic clock 578 reset_signals;
410 # 60 allows for the watchdog to kill the server. 579 &$cb
580 }, @args;
411 581
412 (aio_write $fh, 0, (length $value), $value, 0) <= 0 582 wantarray ? @res : $res[-1]
413 and return; 583}
414 584
415 # always fsync - this file is important 585=item $coin = coin_from_name $name
416 aio_fsync $fh
417 and return;
418 586
419 # touch it again to show we are up-to-date 587=cut
420 aio_utime $fh, undef, undef;
421 588
422 close $fh 589our %coin_alias = (
423 or return; 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);
424 605
425 aio_rename "$runtime~", $runtime 606sub coin_from_name($) {
426 and return; 607 $coin_alias{$_[0]}
608 ? cf::arch::find $coin_alias{$_[0]}
609 : undef
610}
427 611
428 warn "runtime file written.\n"; 612=item $value = cf::db_get $family => $key
429 613
614Returns a single value from the environment database.
615
616=item cf::db_put $family => $key => $value
617
618Stores the given C<$value> in the family. It can currently store binary
619data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
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
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}
644
645our $DB;
646
647sub db_init {
648 cf::sync_job {
649 $DB ||= db_table "db";
650 };
651}
652
653sub db_get($$) {
654 my $key = "$_[0]/$_[1]";
655
656 cf::sync_job {
657 BDB::db_get $DB, undef, $key, my $data;
658
659 $! ? ()
660 : $data
430 1 661 }
662}
663
664sub db_put($$$) {
665 BDB::dbreq_pri 4;
666 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
667}
668
669=item cf::cache $id => [$paths...], $processversion => $process
670
671Generic caching function that returns the value of the resource $id,
672caching and regenerating as required.
673
674This function can block.
675
676=cut
677
678sub cache {
679 my ($id, $src, $processversion, $process) = @_;
680
681 my $meta =
682 join "\x00",
683 $processversion,
684 map {
685 aio_stat $_
686 and Carp::croak "$_: $!";
687
688 ($_, (stat _)[7,9])
689 } @$src;
690
691 my $dbmeta = db_get cache => "$id/meta";
692 if ($dbmeta ne $meta) {
693 # changed, we may need to process
694
695 my @data;
696 my $md5;
697
698 for (0 .. $#$src) {
699 0 <= aio_load $src->[$_], $data[$_]
700 or Carp::croak "$src->[$_]: $!";
701 }
702
703 # if processing is expensive, check
704 # checksum first
705 if (1) {
706 $md5 =
707 join "\x00",
708 $processversion,
709 map {
710 cf::cede_to_tick;
711 ($src->[$_], Digest::MD5::md5_hex $data[$_])
712 } 0.. $#$src;
713
714
715 my $dbmd5 = db_get cache => "$id/md5";
716 if ($dbmd5 eq $md5) {
717 db_put cache => "$id/meta", $meta;
718
719 return db_get cache => "$id/data";
720 }
721 }
722
723 my $t1 = Time::HiRes::time;
724 my $data = $process->(\@data);
725 my $t2 = Time::HiRes::time;
726
727 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
728
729 db_put cache => "$id/data", $data;
730 db_put cache => "$id/md5" , $md5;
731 db_put cache => "$id/meta", $meta;
732
733 return $data;
734 }
735
736 db_get cache => "$id/data"
431} 737}
432 738
433=item cf::datalog type => key => value, ... 739=item cf::datalog type => key => value, ...
434 740
435Log a datalog packet of the given type with the given key-value pairs. 741Log a datalog packet of the given type with the given key-value pairs.
… …
447 753
448############################################################################# 754#############################################################################
449 755
450=head2 ATTACHABLE OBJECTS 756=head2 ATTACHABLE OBJECTS
451 757
452Many 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
453attach callbacks/event handlers (a collection of which is called an "attachment") 759attach callbacks/event handlers (a collection of which is called an "attachment")
454to it. All such attachable objects support the following methods. 760to it. All such attachable objects support the following methods.
455 761
456In 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>
457C<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
458crossfire+). 764Deliantra).
459 765
460=over 4 766=over 4
461 767
462=item $attachable->attach ($attachment, key => $value...) 768=item $attachable->attach ($attachment, key => $value...)
463 769
… …
507=item cf::CLASS::attachment $name, ... 813=item cf::CLASS::attachment $name, ...
508 814
509Register an attachment by C<$name> through which attachable objects of the 815Register an attachment by C<$name> through which attachable objects of the
510given CLASS can refer to this attachment. 816given CLASS can refer to this attachment.
511 817
512Some classes such as crossfire maps and objects can specify attachments 818Some classes such as deliantra maps and objects can specify attachments
513that 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.
514 820
515These calls expect any number of the following handler/hook descriptions: 821These calls expect any number of the following handler/hook descriptions:
516 822
517=over 4 823=over 4
… …
665 _attach $registry, $klass, @attach; 971 _attach $registry, $klass, @attach;
666 } 972 }
667 973
668 $obj->{$name} = \%arg; 974 $obj->{$name} = \%arg;
669 } else { 975 } else {
670 warn "object uses attachment '$name' that is not available, postponing.\n"; 976 warn "object uses attachment '$name' which is not available, postponing.\n";
671 } 977 }
672 978
673 $obj->{_attachment}{$name} = undef; 979 $obj->{_attachment}{$name} = undef;
674} 980}
675 981
… …
715 "; 1021 ";
716 die if $@; 1022 die if $@;
717} 1023}
718 1024
719our $override; 1025our $override;
720our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 1026our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
721 1027
722sub override { 1028sub override {
723 $override = 1; 1029 $override = 1;
724 @invoke_results = (); 1030 @INVOKE_RESULTS = (@_);
725} 1031}
726 1032
727sub do_invoke { 1033sub do_invoke {
728 my $event = shift; 1034 my $event = shift;
729 my $callbacks = shift; 1035 my $callbacks = shift;
730 1036
731 @invoke_results = (); 1037 @INVOKE_RESULTS = ();
732 1038
733 local $override; 1039 local $override;
734 1040
735 for (@$callbacks) { 1041 for (@$callbacks) {
736 eval { &{$_->[1]} }; 1042 eval { &{$_->[1]} };
… …
745 } 1051 }
746 1052
747 0 1053 0
748} 1054}
749 1055
750=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1056=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
751 1057
752=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1058=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
753 1059
754Generate an object-specific event with the given arguments. 1060Generate an object-specific event with the given arguments.
755 1061
756This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1062This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
757removed in future versions), and there is no public API to access override 1063removed in future versions), and there is no public API to access override
758results (if you must, access C<@cf::invoke_results> directly). 1064results (if you must, access C<@cf::INVOKE_RESULTS> directly).
759 1065
760=back 1066=back
761 1067
762=cut 1068=cut
763 1069
764############################################################################# 1070#############################################################################
765# object support 1071# object support
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#
1106sub _can_merge {
1107 my ($ob1, $ob2) = @_;
1108
1109 ++$SLOW_MERGES;#d#
1110
1111 # we do the slow way here
1112 return _object_equal $ob1, $ob2
1113}
766 1114
767sub reattach { 1115sub reattach {
768 # basically do the same as instantiate, without calling instantiate 1116 # basically do the same as instantiate, without calling instantiate
769 my ($obj) = @_; 1117 my ($obj) = @_;
770 1118
1119 # no longer needed after getting rid of delete_package?
771 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
772 1121
773 my $registry = $obj->registry; 1122 my $registry = $obj->registry;
774 1123
775 @$registry = (); 1124 @$registry = ();
776 1125
… …
791cf::attachable->attach ( 1140cf::attachable->attach (
792 prio => -1000000, 1141 prio => -1000000,
793 on_instantiate => sub { 1142 on_instantiate => sub {
794 my ($obj, $data) = @_; 1143 my ($obj, $data) = @_;
795 1144
796 $data = from_json $data; 1145 $data = decode_json $data;
797 1146
798 for (@$data) { 1147 for (@$data) {
799 my ($name, $args) = @$_; 1148 my ($name, $args) = @$_;
800 1149
801 $obj->attach ($name, %{$args || {} }); 1150 $obj->attach ($name, %{$args || {} });
… …
817sub object_freezer_save { 1166sub object_freezer_save {
818 my ($filename, $rdata, $objs) = @_; 1167 my ($filename, $rdata, $objs) = @_;
819 1168
820 sync_job { 1169 sync_job {
821 if (length $$rdata) { 1170 if (length $$rdata) {
1171 utf8::decode (my $decname = $filename);
822 warn sprintf "saving %s (%d,%d)\n", 1172 warn sprintf "saving %s (%d,%d)\n",
823 $filename, length $$rdata, scalar @$objs; 1173 $decname, length $$rdata, scalar @$objs;
824 1174
825 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1175 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
826 chmod SAVE_MODE, $fh; 1176 aio_chmod $fh, SAVE_MODE;
827 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1177 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
828 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 }
829 close $fh; 1182 aio_close $fh;
830 1183
831 if (@$objs) { 1184 if (@$objs) {
832 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) {
833 chmod SAVE_MODE, $fh; 1186 aio_chmod $fh, SAVE_MODE;
834 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1187 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
835 aio_write $fh, 0, (length $data), $data, 0; 1188 aio_write $fh, 0, (length $data), $data, 0;
836 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 }
837 close $fh; 1193 aio_close $fh;
838 aio_rename "$filename.pst~", "$filename.pst"; 1194 aio_rename "$filename.pst~", "$filename.pst";
839 } 1195 }
840 } else { 1196 } else {
841 aio_unlink "$filename.pst"; 1197 aio_unlink "$filename.pst";
842 } 1198 }
843 1199
844 aio_rename "$filename~", $filename; 1200 aio_rename "$filename~", $filename;
1201
1202 $filename =~ s%/[^/]+$%%;
1203 aio_pathsync $filename if $cf::USE_FSYNC;
845 } else { 1204 } else {
846 warn "FATAL: $filename~: $!\n"; 1205 warn "unable to save objects: $filename~: $!\n";
847 } 1206 }
848 } else { 1207 } else {
849 aio_unlink $filename; 1208 aio_unlink $filename;
850 aio_unlink "$filename.pst"; 1209 aio_unlink "$filename.pst";
851 } 1210 }
852 } 1211 };
853} 1212}
854 1213
855sub object_freezer_as_string { 1214sub object_freezer_as_string {
856 my ($rdata, $objs) = @_; 1215 my ($rdata, $objs) = @_;
857 1216
… …
869 or return; 1228 or return;
870 1229
871 unless (aio_stat "$filename.pst") { 1230 unless (aio_stat "$filename.pst") {
872 (aio_load "$filename.pst", $av) >= 0 1231 (aio_load "$filename.pst", $av) >= 0
873 or return; 1232 or return;
1233
874 $av = eval { (Storable::thaw $av)->{objs} }; 1234 my $st = eval { Coro::Storable::thaw $av };
1235 $av = $st->{objs};
875 } 1236 }
876 1237
1238 utf8::decode (my $decname = $filename);
877 warn sprintf "loading %s (%d)\n", 1239 warn sprintf "loading %s (%d,%d)\n",
878 $filename, length $data, scalar @{$av || []}; 1240 $decname, length $data, scalar @{$av || []};
1241
879 return ($data, $av); 1242 ($data, $av)
880} 1243}
1244
1245=head2 COMMAND CALLBACKS
1246
1247=over 4
1248
1249=cut
881 1250
882############################################################################# 1251#############################################################################
883# command handling &c 1252# command handling &c
884 1253
885=item cf::register_command $name => \&callback($ob,$args); 1254=item cf::register_command $name => \&callback($ob,$args);
… …
898 push @{ $COMMAND{$name} }, [$caller, $cb]; 1267 push @{ $COMMAND{$name} }, [$caller, $cb];
899} 1268}
900 1269
901=item cf::register_extcmd $name => \&callback($pl,$packet); 1270=item cf::register_extcmd $name => \&callback($pl,$packet);
902 1271
903Register a callbackf ro execution when the client sends an extcmd packet. 1272Register a callback for execution when the client sends an (synchronous)
1273extcmd packet. Ext commands will be processed in the order they are
1274received by the server, like other user commands. The first argument is
1275the logged-in player. Ext commands can only be processed after a player
1276has logged in successfully.
904 1277
905If the callback returns something, it is sent back as if reply was being 1278If the callback returns something, it is sent back as if reply was being
906called. 1279called.
907 1280
1281=item cf::register_exticmd $name => \&callback($ns,$packet);
1282
1283Register a callback for execution when the client sends an (asynchronous)
1284exticmd packet. Exti commands are processed by the server as soon as they
1285are received, i.e. out of order w.r.t. other commands. The first argument
1286is a client socket. Exti commands can be received anytime, even before
1287log-in.
1288
1289If the callback returns something, it is sent back as if reply was being
1290called.
1291
908=cut 1292=cut
909 1293
910sub register_extcmd { 1294sub register_extcmd {
911 my ($name, $cb) = @_; 1295 my ($name, $cb) = @_;
912 1296
913 $EXTCMD{$name} = $cb; 1297 $EXTCMD{$name} = $cb;
914} 1298}
1299
1300sub register_exticmd {
1301 my ($name, $cb) = @_;
1302
1303 $EXTICMD{$name} = $cb;
1304}
1305
1306use File::Glob ();
915 1307
916cf::player->attach ( 1308cf::player->attach (
917 on_command => sub { 1309 on_command => sub {
918 my ($pl, $name, $params) = @_; 1310 my ($pl, $name, $params) = @_;
919 1311
… …
927 cf::override; 1319 cf::override;
928 }, 1320 },
929 on_extcmd => sub { 1321 on_extcmd => sub {
930 my ($pl, $buf) = @_; 1322 my ($pl, $buf) = @_;
931 1323
932 my $msg = eval { from_json $buf }; 1324 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
933 1325
934 if (ref $msg) { 1326 if (ref $msg) {
1327 my ($type, $reply, @payload) =
1328 "ARRAY" eq ref $msg
1329 ? @$msg
1330 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1331
1332 my @reply;
1333
935 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1334 if (my $cb = $EXTCMD{$type}) {
936 if (my %reply = $cb->($pl, $msg)) { 1335 @reply = $cb->($pl, @payload);
937 $pl->ext_reply ($msg->{msgid}, %reply);
938 }
939 } 1336 }
1337
1338 $pl->ext_reply ($reply, @reply)
1339 if $reply;
1340
940 } else { 1341 } else {
941 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1342 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
942 } 1343 }
943 1344
944 cf::override; 1345 cf::override;
945 }, 1346 },
946); 1347);
947 1348
1349# "readahead" all extensions
948sub load_extension { 1350sub cache_extensions {
949 my ($path) = @_; 1351 my $grp = IO::AIO::aio_group;
950 1352
951 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1353 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
952 my $base = $1; 1354 for (grep /\.ext$/, @{$_[0]}) {
953 my $pkg = $1; 1355 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
954 $pkg =~ s/[^[:word:]]/_/g;
955 $pkg = "ext::$pkg";
956
957 warn "... loading '$path' into '$pkg'\n";
958
959 open my $fh, "<:utf8", $path
960 or die "$path: $!";
961
962 my $source =
963 "package $pkg; use strict; use utf8;\n"
964 . "#line 1 \"$path\"\n{\n"
965 . (do { local $/; <$fh> })
966 . "\n};\n1";
967
968 unless (eval $source) {
969 my $msg = $@ ? "$path: $@\n"
970 : "extension disabled.\n";
971 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
972 warn $@;
973 warn "mandatory extension failed to load, exiting.\n";
974 exit 1;
975 } 1356 }
976 die $@;
977 } 1357 };
978 1358
979 push @EXTS, $pkg; 1359 $grp
980} 1360}
981 1361
982sub load_extensions { 1362sub load_extensions {
1363 cf::sync_job {
1364 my %todo;
1365
983 for my $ext (<$LIBDIR/*.ext>) { 1366 for my $path (<$LIBDIR/*.ext>) {
984 next unless -r $ext; 1367 next unless -r $path;
985 eval { 1368
986 load_extension $ext; 1369 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1370 my $base = $1;
1371 my $pkg = $1;
1372 $pkg =~ s/[^[:word:]]/_/g;
1373 $pkg = "ext::$pkg";
1374
1375 open my $fh, "<:utf8", $path
1376 or die "$path: $!";
1377
1378 my $source = do { local $/; <$fh> };
1379
1380 my %ext = (
1381 path => $path,
1382 base => $base,
1383 pkg => $pkg,
1384 );
1385
1386 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1387 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1388
1389 $ext{source} =
1390 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1391 . "#line 1 \"$path\"\n{\n"
1392 . $source
1393 . "\n};\n1";
1394
1395 $todo{$base} = \%ext;
1396 }
1397
1398 my %done;
1399 while (%todo) {
1400 my $progress;
1401
1402 while (my ($k, $v) = each %todo) {
1403 for (split /,\s*/, $v->{meta}{depends}) {
1404 goto skip
1405 unless exists $done{$_};
1406 }
1407
1408 warn "... loading '$k' into '$v->{pkg}'\n";
1409
1410 unless (eval $v->{source}) {
1411 my $msg = $@ ? "$v->{path}: $@\n"
1412 : "$v->{base}: extension inactive.\n";
1413
1414 if (exists $v->{meta}{mandatory}) {
1415 warn $msg;
1416 cf::cleanup "mandatory extension failed to load, exiting.";
1417 }
1418
1419 warn $msg;
1420 }
1421
1422 $done{$k} = delete $todo{$k};
1423 push @EXTS, $v->{pkg};
1424 $progress = 1;
987 1 1425 }
988 } or warn "$ext not loaded: $@"; 1426
1427 skip:
1428 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1429 unless $progress;
1430 }
989 } 1431 };
990} 1432}
991 1433
992############################################################################# 1434#############################################################################
993 1435
1436=back
1437
994=head2 CORE EXTENSIONS 1438=head2 CORE EXTENSIONS
995 1439
996Functions and methods that extend core crossfire objects. 1440Functions and methods that extend core deliantra objects.
997 1441
998=cut 1442=cut
999 1443
1000package cf::player; 1444package cf::player;
1001 1445
1002use Coro::AIO; 1446use Coro::AIO;
1003 1447
1004=head3 cf::player 1448=head3 cf::player
1005 1449
1006=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}
1007 1465
1008=item cf::player::find $login 1466=item cf::player::find $login
1009 1467
1010Returns the given player object, loading it if necessary (might block). 1468Returns the given player object, loading it if necessary (might block).
1011 1469
… …
1030 1488
1031sub exists($) { 1489sub exists($) {
1032 my ($login) = @_; 1490 my ($login) = @_;
1033 1491
1034 $cf::PLAYER{$login} 1492 $cf::PLAYER{$login}
1035 or cf::sync_job { !aio_stat path $login } 1493 or !aio_stat path $login
1036} 1494}
1037 1495
1038sub find($) { 1496sub find($) {
1039 return $cf::PLAYER{$_[0]} || do { 1497 return $cf::PLAYER{$_[0]} || do {
1040 my $login = $_[0]; 1498 my $login = $_[0];
… …
1047 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1505 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1048 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1506 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1049 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1507 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1050 aio_unlink +(playerdir $login) . "/$login.pl"; 1508 aio_unlink +(playerdir $login) . "/$login.pl";
1051 1509
1052 my $pl = load_pl path $login 1510 my $f = new_from_file cf::object::thawer path $login
1053 or return; 1511 or return;
1512
1513 my $pl = cf::player::load_pl $f
1514 or return;
1515
1516 local $cf::PLAYER_LOADING{$login} = $pl;
1517 $f->resolve_delayed_derefs;
1054 $cf::PLAYER{$login} = $pl 1518 $cf::PLAYER{$login} = $pl
1055 } 1519 }
1056 } 1520 }
1057} 1521}
1058 1522
… …
1067 return if $pl->{deny_save}; 1531 return if $pl->{deny_save};
1068 1532
1069 aio_mkdir playerdir $pl, 0770; 1533 aio_mkdir playerdir $pl, 0770;
1070 $pl->{last_save} = $cf::RUNTIME; 1534 $pl->{last_save} = $cf::RUNTIME;
1071 1535
1536 cf::get_slot 0.01;
1537
1072 $pl->save_pl ($path); 1538 $pl->save_pl ($path);
1073 Coro::cede; 1539 cf::cede_to_tick;
1074} 1540}
1075 1541
1076sub new($) { 1542sub new($) {
1077 my ($login) = @_; 1543 my ($login) = @_;
1078 1544
… …
1084 $cf::PLAYER{$login} = $self; 1550 $cf::PLAYER{$login} = $self;
1085 1551
1086 $self 1552 $self
1087} 1553}
1088 1554
1555=item $player->send_msg ($channel, $msg, $color, [extra...])
1556
1557=cut
1558
1559sub send_msg {
1560 my $ns = shift->ns
1561 or return;
1562 $ns->send_msg (@_);
1563}
1564
1089=item $pl->quit_character 1565=item $pl->quit_character
1090 1566
1091Nukes the player without looking back. If logged in, the connection will 1567Nukes the player without looking back. If logged in, the connection will
1092be destroyed. May block for a long time. 1568be destroyed. May block for a long time.
1093 1569
… …
1097 my ($pl) = @_; 1573 my ($pl) = @_;
1098 1574
1099 my $name = $pl->ob->name; 1575 my $name = $pl->ob->name;
1100 1576
1101 $pl->{deny_save} = 1; 1577 $pl->{deny_save} = 1;
1102 $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
1103 1579
1104 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1580 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1105 $pl->deactivate; 1581 $pl->deactivate;
1582 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1583 $pl->ob->check_score;
1106 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1584 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1107 $pl->ns->destroy if $pl->ns; 1585 $pl->ns->destroy if $pl->ns;
1108 1586
1109 my $path = playerdir $pl; 1587 my $path = playerdir $pl;
1110 my $temp = "$path~$cf::RUNTIME~deleting~"; 1588 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1146 or return []; 1624 or return [];
1147 1625
1148 my @logins; 1626 my @logins;
1149 1627
1150 for my $login (@$dirs) { 1628 for my $login (@$dirs) {
1629 my $path = path $login;
1630
1631 # a .pst is a dead give-away for a valid player
1632 # if no pst file found, open and chekc for blocked users
1633 if (aio_stat "$path.pst") {
1151 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1634 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1152 aio_read $fh, 0, 512, my $buf, 0 or next; 1635 aio_read $fh, 0, 512, my $buf, 0 or next;
1153 $buf !~ /^password -------------$/m or next; # official not-valid tag 1636 $buf !~ /^password -------------$/m or next; # official not-valid tag
1637 }
1154 1638
1155 utf8::decode $login; 1639 utf8::decode $login;
1156 push @logins, $login; 1640 push @logins, $login;
1157 } 1641 }
1158 1642
… …
1185 } 1669 }
1186 1670
1187 \@paths 1671 \@paths
1188} 1672}
1189 1673
1674=item $protocol_xml = $player->expand_cfpod ($cfpod)
1675
1676Expand deliantra pod fragments into protocol xml.
1677
1190=item $player->ext_reply ($msgid, %msg) 1678=item $player->ext_reply ($msgid, @msg)
1191 1679
1192Sends an ext reply to the player. 1680Sends an ext reply to the player.
1193 1681
1194=cut 1682=cut
1195 1683
1196sub ext_reply($$%) { 1684sub ext_reply($$@) {
1197 my ($self, $id, %msg) = @_; 1685 my ($self, $id, @msg) = @_;
1198 1686
1199 $msg{msgid} = $id; 1687 $self->ns->ext_reply ($id, @msg)
1200
1201 $self->send ("ext " . cf::to_json \%msg);
1202} 1688}
1203 1689
1204=item $player->ext_event ($type, %msg) 1690=item $player->ext_msg ($type, @msg)
1205 1691
1206Sends an ext event to the client. 1692Sends an ext event to the client.
1207 1693
1208=cut 1694=cut
1209 1695
1210sub ext_event($$%) { 1696sub ext_msg($$@) {
1211 my ($self, $type, %msg) = @_; 1697 my ($self, $type, @msg) = @_;
1212 1698
1213 $self->ns->ext_event ($type, %msg); 1699 $self->ns->ext_msg ($type, @msg);
1214} 1700}
1215 1701
1216=head3 cf::region 1702=head3 cf::region
1217 1703
1218=over 4 1704=over 4
… …
1221 1707
1222package cf::region; 1708package cf::region;
1223 1709
1224=item cf::region::find_by_path $path 1710=item cf::region::find_by_path $path
1225 1711
1226Tries to decuce the probable region for a map knowing only its path. 1712Tries to decuce the likely region for a map knowing only its path.
1227 1713
1228=cut 1714=cut
1229 1715
1230sub find_by_path($) { 1716sub find_by_path($) {
1231 my ($path) = @_; 1717 my ($path) = @_;
1232 1718
1233 my ($match, $specificity); 1719 my ($match, $specificity);
1234 1720
1235 for my $region (list) { 1721 for my $region (list) {
1236 if ($region->match && $path =~ $region->match) { 1722 if ($region->{match} && $path =~ $region->{match}) {
1237 ($match, $specificity) = ($region, $region->specificity) 1723 ($match, $specificity) = ($region, $region->specificity)
1238 if $region->specificity > $specificity; 1724 if $region->specificity > $specificity;
1239 } 1725 }
1240 } 1726 }
1241 1727
… …
1262our $MAX_RESET = 3600; 1748our $MAX_RESET = 3600;
1263our $DEFAULT_RESET = 3000; 1749our $DEFAULT_RESET = 3000;
1264 1750
1265sub generate_random_map { 1751sub generate_random_map {
1266 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
1267 # mit "rum" bekleckern, nicht 1756 # mit "rum" bekleckern, nicht
1268 $self->_create_random_map ( 1757 $self->_create_random_map (
1269 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1758 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1270 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1759 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1271 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1760 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1361 $self->init; # pass $1 etc. 1850 $self->init; # pass $1 etc.
1362 return $self; 1851 return $self;
1363 } 1852 }
1364 } 1853 }
1365 1854
1366 Carp::carp "unable to resolve path '$path' (base '$base')."; 1855 Carp::cluck "unable to resolve path '$path' (base '$base').";
1367 () 1856 ()
1368} 1857}
1369 1858
1370sub init { 1859sub init {
1371 my ($self) = @_; 1860 my ($self) = @_;
… …
1393 1882
1394# the temporary/swap location 1883# the temporary/swap location
1395sub save_path { 1884sub save_path {
1396 my ($self) = @_; 1885 my ($self) = @_;
1397 1886
1398 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1887 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1399 "$TMPDIR/$path.map" 1888 "$TMPDIR/$path.map"
1400} 1889}
1401 1890
1402# the unique path, undef == no special unique path 1891# the unique path, undef == no special unique path
1403sub uniq_path { 1892sub uniq_path {
1404 my ($self) = @_; 1893 my ($self) = @_;
1405 1894
1406 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1895 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1407 "$UNIQUEDIR/$path" 1896 "$UNIQUEDIR/$path"
1408}
1409
1410# and all this just because we cannot iterate over
1411# all maps in C++...
1412sub change_all_map_light {
1413 my ($change) = @_;
1414
1415 $_->change_map_light ($change)
1416 for grep $_->outdoor, values %cf::MAP;
1417} 1897}
1418 1898
1419sub decay_objects { 1899sub decay_objects {
1420 my ($self) = @_; 1900 my ($self) = @_;
1421 1901
… …
1434 1914
1435sub load_header_from($) { 1915sub load_header_from($) {
1436 my ($self, $path) = @_; 1916 my ($self, $path) = @_;
1437 1917
1438 utf8::encode $path; 1918 utf8::encode $path;
1439 #aio_open $path, O_RDONLY, 0 1919 my $f = new_from_file cf::object::thawer $path
1440 # or return;
1441
1442 $self->_load_header ($path)
1443 or return; 1920 or return;
1921
1922 $self->_load_header ($f)
1923 or return;
1924
1925 local $MAP_LOADING{$self->{path}} = $self;
1926 $f->resolve_delayed_derefs;
1444 1927
1445 $self->{load_path} = $path; 1928 $self->{load_path} = $path;
1446 1929
1447 1 1930 1
1448} 1931}
… …
1502sub find { 1985sub find {
1503 my ($path, $origin) = @_; 1986 my ($path, $origin) = @_;
1504 1987
1505 $path = normalise $path, $origin && $origin->path; 1988 $path = normalise $path, $origin && $origin->path;
1506 1989
1990 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1507 cf::lock_wait "map_find:$path"; 1991 my $guard2 = cf::lock_acquire "map_find:$path";
1508 1992
1509 $cf::MAP{$path} || do { 1993 $cf::MAP{$path} || do {
1510 my $guard = cf::lock_acquire "map_find:$path";
1511 my $map = new_from_path cf::map $path 1994 my $map = new_from_path cf::map $path
1512 or return; 1995 or return;
1513 1996
1514 $map->{last_save} = $cf::RUNTIME; 1997 $map->{last_save} = $cf::RUNTIME;
1515 1998
… …
1517 or return; 2000 or return;
1518 2001
1519 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2002 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1520 # doing this can freeze the server in a sync job, obviously 2003 # doing this can freeze the server in a sync job, obviously
1521 #$cf::WAIT_FOR_TICK->wait; 2004 #$cf::WAIT_FOR_TICK->wait;
2005 undef $guard2;
2006 undef $guard1;
1522 $map->reset; 2007 $map->reset;
1523 undef $guard;
1524 return find $path; 2008 return find $path;
1525 } 2009 }
1526 2010
1527 $cf::MAP{$path} = $map 2011 $cf::MAP{$path} = $map
1528 } 2012 }
… …
1537 local $self->{deny_reset} = 1; # loading can take a long time 2021 local $self->{deny_reset} = 1; # loading can take a long time
1538 2022
1539 my $path = $self->{path}; 2023 my $path = $self->{path};
1540 2024
1541 { 2025 {
1542 my $guard = cf::lock_acquire "map_load:$path"; 2026 my $guard = cf::lock_acquire "map_data:$path";
1543 2027
2028 return unless $self->valid;
1544 return if $self->in_memory != cf::MAP_SWAPPED; 2029 return unless $self->in_memory == cf::MAP_SWAPPED;
1545 2030
1546 $self->in_memory (cf::MAP_LOADING); 2031 $self->in_memory (cf::MAP_LOADING);
1547 2032
1548 $self->alloc; 2033 $self->alloc;
1549 2034
1550 $self->pre_load; 2035 $self->pre_load;
1551 Coro::cede; 2036 cf::cede_to_tick;
1552 2037
2038 my $f = new_from_file cf::object::thawer $self->{load_path};
2039 $f->skip_block;
1553 $self->_load_objects ($self->{load_path}, 1) 2040 $self->_load_objects ($f)
1554 or return; 2041 or return;
1555 2042
1556 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2043 $self->post_load_original
1557 if delete $self->{load_original}; 2044 if delete $self->{load_original};
1558 2045
1559 if (my $uniq = $self->uniq_path) { 2046 if (my $uniq = $self->uniq_path) {
1560 utf8::encode $uniq; 2047 utf8::encode $uniq;
1561 if (aio_open $uniq, O_RDONLY, 0) { 2048 unless (aio_stat $uniq) {
2049 if (my $f = new_from_file cf::object::thawer $uniq) {
1562 $self->clear_unique_items; 2050 $self->clear_unique_items;
1563 $self->_load_objects ($uniq, 0); 2051 $self->_load_objects ($f);
2052 $f->resolve_delayed_derefs;
2053 }
1564 } 2054 }
1565 } 2055 }
1566 2056
1567 Coro::cede; 2057 $f->resolve_delayed_derefs;
2058
2059 cf::cede_to_tick;
1568 # now do the right thing for maps 2060 # now do the right thing for maps
1569 $self->link_multipart_objects; 2061 $self->link_multipart_objects;
1570 $self->difficulty ($self->estimate_difficulty) 2062 $self->difficulty ($self->estimate_difficulty)
1571 unless $self->difficulty; 2063 unless $self->difficulty;
1572 Coro::cede; 2064 cf::cede_to_tick;
1573 2065
1574 unless ($self->{deny_activate}) { 2066 unless ($self->{deny_activate}) {
1575 $self->decay_objects; 2067 $self->decay_objects;
1576 $self->fix_auto_apply; 2068 $self->fix_auto_apply;
1577 $self->update_buttons; 2069 $self->update_buttons;
1578 Coro::cede; 2070 cf::cede_to_tick;
1579 $self->set_darkness_map;
1580 Coro::cede;
1581 $self->activate; 2071 $self->activate;
1582 } 2072 }
1583 2073
2074 $self->{last_save} = $cf::RUNTIME;
2075 $self->last_access ($cf::RUNTIME);
2076
1584 $self->in_memory (cf::MAP_IN_MEMORY); 2077 $self->in_memory (cf::MAP_ACTIVE);
1585 } 2078 }
1586 2079
1587 $self->post_load; 2080 $self->post_load;
1588} 2081}
1589 2082
… …
1598 2091
1599 $self 2092 $self
1600} 2093}
1601 2094
1602# find and load all maps in the 3x3 area around a map 2095# find and load all maps in the 3x3 area around a map
1603sub load_diag { 2096sub load_neighbours {
1604 my ($map) = @_; 2097 my ($map) = @_;
1605 2098
1606 my @diag; # diagonal neighbours 2099 my @neigh; # diagonal neighbours
1607 2100
1608 for (0 .. 3) { 2101 for (0 .. 3) {
1609 my $neigh = $map->tile_path ($_) 2102 my $neigh = $map->tile_path ($_)
1610 or next; 2103 or next;
1611 $neigh = find $neigh, $map 2104 $neigh = find $neigh, $map
1612 or next; 2105 or next;
1613 $neigh->load; 2106 $neigh->load;
1614 2107
2108 push @neigh,
1615 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2109 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1616 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2110 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1617 } 2111 }
1618 2112
1619 for (@diag) { 2113 for (grep defined $_->[0], @neigh) {
2114 my ($path, $origin) = @$_;
1620 my $neigh = find @$_ 2115 my $neigh = find $path, $origin
1621 or next; 2116 or next;
1622 $neigh->load; 2117 $neigh->load;
1623 } 2118 }
1624} 2119}
1625 2120
… …
1630} 2125}
1631 2126
1632sub do_load_sync { 2127sub do_load_sync {
1633 my ($map) = @_; 2128 my ($map) = @_;
1634 2129
2130 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2131 if $Coro::current == $Coro::main;
2132
1635 cf::sync_job { $map->load }; 2133 cf::sync_job { $map->load };
1636} 2134}
1637 2135
1638our %MAP_PREFETCH; 2136our %MAP_PREFETCH;
1639our $MAP_PREFETCHER = undef; 2137our $MAP_PREFETCHER = undef;
1640 2138
1641sub find_async { 2139sub find_async {
1642 my ($path, $origin) = @_; 2140 my ($path, $origin, $load) = @_;
1643 2141
1644 $path = normalise $path, $origin && $origin->{path}; 2142 $path = normalise $path, $origin && $origin->{path};
1645 2143
1646 if (my $map = $cf::MAP{$path}) { 2144 if (my $map = $cf::MAP{$path}) {
1647 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2145 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1648 } 2146 }
1649 2147
1650 undef $MAP_PREFETCH{$path}; 2148 $MAP_PREFETCH{$path} |= $load;
2149
1651 $MAP_PREFETCHER ||= cf::async { 2150 $MAP_PREFETCHER ||= cf::async {
2151 $Coro::current->{desc} = "map prefetcher";
2152
1652 while (%MAP_PREFETCH) { 2153 while (%MAP_PREFETCH) {
1653 for my $path (keys %MAP_PREFETCH) { 2154 while (my ($k, $v) = each %MAP_PREFETCH) {
1654 my $map = find $path 2155 if (my $map = find $k) {
1655 or next;
1656 $map->load; 2156 $map->load if $v;
2157 }
1657 2158
1658 delete $MAP_PREFETCH{$path}; 2159 delete $MAP_PREFETCH{$k};
1659 } 2160 }
1660 } 2161 }
1661 undef $MAP_PREFETCHER; 2162 undef $MAP_PREFETCHER;
1662 }; 2163 };
1663 $MAP_PREFETCHER->prio (6); 2164 $MAP_PREFETCHER->prio (6);
… …
1666} 2167}
1667 2168
1668sub save { 2169sub save {
1669 my ($self) = @_; 2170 my ($self) = @_;
1670 2171
1671 my $lock = cf::lock_acquire "map_data:" . $self->path; 2172 my $lock = cf::lock_acquire "map_data:$self->{path}";
1672 2173
1673 $self->{last_save} = $cf::RUNTIME; 2174 $self->{last_save} = $cf::RUNTIME;
1674 2175
1675 return unless $self->dirty; 2176 return unless $self->dirty;
1676 2177
… …
1682 return if $self->{deny_save}; 2183 return if $self->{deny_save};
1683 2184
1684 local $self->{last_access} = $self->last_access;#d# 2185 local $self->{last_access} = $self->last_access;#d#
1685 2186
1686 cf::async { 2187 cf::async {
2188 $Coro::current->{desc} = "map player save";
1687 $_->contr->save for $self->players; 2189 $_->contr->save for $self->players;
1688 }; 2190 };
2191
2192 cf::get_slot 0.02;
1689 2193
1690 if ($uniq) { 2194 if ($uniq) {
1691 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2195 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1692 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2196 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1693 } else { 2197 } else {
… …
1699 my ($self) = @_; 2203 my ($self) = @_;
1700 2204
1701 # save first because save cedes 2205 # save first because save cedes
1702 $self->save; 2206 $self->save;
1703 2207
1704 my $lock = cf::lock_acquire "map_data:" . $self->path; 2208 my $lock = cf::lock_acquire "map_data:$self->{path}";
1705 2209
1706 return if $self->players; 2210 return if $self->players;
1707 return if $self->in_memory != cf::MAP_IN_MEMORY; 2211 return if $self->in_memory != cf::MAP_ACTIVE;
1708 return if $self->{deny_save}; 2212 return if $self->{deny_save};
1709 2213
2214 $self->in_memory (cf::MAP_SWAPPED);
2215
2216 $self->deactivate;
2217 $_->clear_links_to ($self) for values %cf::MAP;
1710 $self->clear; 2218 $self->clear;
1711 $self->in_memory (cf::MAP_SWAPPED);
1712} 2219}
1713 2220
1714sub reset_at { 2221sub reset_at {
1715 my ($self) = @_; 2222 my ($self) = @_;
1716 2223
… …
1734 2241
1735 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2242 my $lock = cf::lock_acquire "map_data:$self->{path}";
1736 2243
1737 return if $self->players; 2244 return if $self->players;
1738 2245
1739 warn "resetting map ", $self->path; 2246 warn "resetting map ", $self->path, "\n";
1740 2247
1741 $self->in_memory (cf::MAP_SWAPPED); 2248 $self->in_memory (cf::MAP_SWAPPED);
1742 2249
1743 # need to save uniques path 2250 # need to save uniques path
1744 unless ($self->{deny_save}) { 2251 unless ($self->{deny_save}) {
… …
1748 if $uniq; 2255 if $uniq;
1749 } 2256 }
1750 2257
1751 delete $cf::MAP{$self->path}; 2258 delete $cf::MAP{$self->path};
1752 2259
2260 $self->deactivate;
2261 $_->clear_links_to ($self) for values %cf::MAP;
1753 $self->clear; 2262 $self->clear;
1754
1755 $_->clear_links_to ($self) for values %cf::MAP;
1756 2263
1757 $self->unlink_save; 2264 $self->unlink_save;
1758 $self->destroy; 2265 $self->destroy;
1759} 2266}
1760 2267
1761my $nuke_counter = "aaaa"; 2268my $nuke_counter = "aaaa";
1762 2269
1763sub nuke { 2270sub nuke {
1764 my ($self) = @_; 2271 my ($self) = @_;
1765 2272
2273 {
2274 my $lock = cf::lock_acquire "map_data:$self->{path}";
2275
1766 delete $cf::MAP{$self->path}; 2276 delete $cf::MAP{$self->path};
1767 2277
1768 $self->unlink_save; 2278 $self->unlink_save;
1769 2279
1770 bless $self, "cf::map"; 2280 bless $self, "cf::map";
1771 delete $self->{deny_reset}; 2281 delete $self->{deny_reset};
1772 $self->{deny_save} = 1; 2282 $self->{deny_save} = 1;
1773 $self->reset_timeout (1); 2283 $self->reset_timeout (1);
1774 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2284 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1775 2285
1776 $cf::MAP{$self->path} = $self; 2286 $cf::MAP{$self->path} = $self;
2287 }
1777 2288
1778 $self->reset; # polite request, might not happen 2289 $self->reset; # polite request, might not happen
2290}
2291
2292=item $maps = cf::map::tmp_maps
2293
2294Returns an arrayref with all map paths of currently instantiated and saved
2295maps. May block.
2296
2297=cut
2298
2299sub tmp_maps() {
2300 [
2301 map {
2302 utf8::decode $_;
2303 /\.map$/
2304 ? normalise $_
2305 : ()
2306 } @{ aio_readdir $TMPDIR or [] }
2307 ]
2308}
2309
2310=item $maps = cf::map::random_maps
2311
2312Returns an arrayref with all map paths of currently instantiated and saved
2313random maps. May block.
2314
2315=cut
2316
2317sub random_maps() {
2318 [
2319 map {
2320 utf8::decode $_;
2321 /\.map$/
2322 ? normalise "?random/$_"
2323 : ()
2324 } @{ aio_readdir $RANDOMDIR or [] }
2325 ]
1779} 2326}
1780 2327
1781=item cf::map::unique_maps 2328=item cf::map::unique_maps
1782 2329
1783Returns an arrayref of paths of all shared maps that have 2330Returns an arrayref of paths of all shared maps that have
1784instantiated unique items. May block. 2331instantiated unique items. May block.
1785 2332
1786=cut 2333=cut
1787 2334
1788sub unique_maps() { 2335sub unique_maps() {
1789 my $files = aio_readdir $UNIQUEDIR 2336 [
1790 or return; 2337 map {
1791
1792 my @paths;
1793
1794 for (@$files) {
1795 utf8::decode $_; 2338 utf8::decode $_;
1796 next if /\.pst$/; 2339 s/\.map$//; # TODO future compatibility hack
1797 next unless /^$PATH_SEP/o; 2340 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1798 2341 ? ()
1799 push @paths, cf::map::normalise $_; 2342 : normalise $_
2343 } @{ aio_readdir $UNIQUEDIR or [] }
1800 } 2344 ]
1801
1802 \@paths
1803} 2345}
1804 2346
1805package 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}
1806 2378
1807=back 2379=back
1808 2380
1809=head3 cf::object 2381=head3 cf::object
1810 2382
… …
1814 2386
1815=over 4 2387=over 4
1816 2388
1817=item $ob->inv_recursive 2389=item $ob->inv_recursive
1818 2390
1819Returns 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.
1820 2393
1821=cut 2394=cut
1822 2395
1823sub inv_recursive_; 2396sub inv_recursive_;
1824sub inv_recursive_ { 2397sub inv_recursive_ {
… …
1827 2400
1828sub inv_recursive { 2401sub inv_recursive {
1829 inv_recursive_ inv $_[0] 2402 inv_recursive_ inv $_[0]
1830} 2403}
1831 2404
2405=item $ref = $ob->ref
2406
2407Creates and returns a persistent reference to an object that can be stored as a string.
2408
2409=item $ob = cf::object::deref ($refstring)
2410
2411returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2412even if the object actually exists. May block.
2413
2414=cut
2415
2416sub deref {
2417 my ($ref) = @_;
2418
2419 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2420 my ($uuid, $name) = ($1, $2);
2421 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2422 or return;
2423 $pl->ob->uuid eq $uuid
2424 or return;
2425
2426 $pl->ob
2427 } else {
2428 warn "$ref: cannot resolve object reference\n";
2429 undef
2430 }
2431}
2432
1832package cf; 2433package cf;
1833 2434
1834=back 2435=back
1835 2436
1836=head3 cf::object::player 2437=head3 cf::object::player
… …
1842Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2443Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1843can 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
1844dialogue with the given NPC character. 2445dialogue with the given NPC character.
1845 2446
1846=cut 2447=cut
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};
1847 2462
1848# rough implementation of a future "reply" method that works 2463# rough implementation of a future "reply" method that works
1849# with dialog boxes. 2464# with dialog boxes.
1850#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
1851sub cf::object::player::reply($$$;$) { 2466sub cf::object::player::reply($$$;$) {
… …
1853 2468
1854 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2469 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1855 2470
1856 if ($self->{record_replies}) { 2471 if ($self->{record_replies}) {
1857 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2472 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2473
1858 } else { 2474 } else {
2475 my $pl = $self->contr;
2476
2477 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2478 my $dialog = $pl->{npc_dialog};
2479 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2480
2481 } else {
1859 $msg = $npc->name . " says: $msg" if $npc; 2482 $msg = $npc->name . " says: $msg" if $npc;
1860 $self->message ($msg, $flags); 2483 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2484 }
1861 } 2485 }
2486}
2487
2488=item $object->send_msg ($channel, $msg, $color, [extra...])
2489
2490=cut
2491
2492sub cf::object::send_msg {
2493 my $pl = shift->contr
2494 or return;
2495 $pl->send_msg (@_);
1862} 2496}
1863 2497
1864=item $player_object->may ("access") 2498=item $player_object->may ("access")
1865 2499
1866Returns wether the given player is authorized to access resource "access" 2500Returns wether the given player is authorized to access resource "access"
… …
1879 2513
1880=item $player_object->enter_link 2514=item $player_object->enter_link
1881 2515
1882Freezes 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}>).
1883 2517
1884The 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.
1885I<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.
1886 2522
1887Will never block. 2523Will never block.
1888 2524
1889=item $player_object->leave_link ($map, $x, $y) 2525=item $player_object->leave_link ($map, $x, $y)
1890 2526
… …
1942 ($x, $y) = (-1, -1) 2578 ($x, $y) = (-1, -1)
1943 unless (defined $x) && (defined $y); 2579 unless (defined $x) && (defined $y);
1944 2580
1945 # use -1 or undef as default coordinates, not 0, 0 2581 # use -1 or undef as default coordinates, not 0, 0
1946 ($x, $y) = ($map->enter_x, $map->enter_y) 2582 ($x, $y) = ($map->enter_x, $map->enter_y)
1947 if $x <=0 && $y <= 0; 2583 if $x <= 0 && $y <= 0;
1948 2584
1949 $map->load; 2585 $map->load;
1950 $map->load_diag; 2586 $map->load_neighbours;
1951 2587
1952 return unless $self->contr->active; 2588 return unless $self->contr->active;
1953 $self->activate_recursive;
1954 2589
1955 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2590 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1956 $self->enter_map ($map, $x, $y); 2591 $self->enter_map ($map, $x, $y);
1957}
1958 2592
2593 # only activate afterwards, to support waiting in hooks
2594 $self->activate_recursive;
2595}
2596
1959=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2597=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1960 2598
1961Moves 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
1962her, loading and preparing them map, calling the provided $check callback 2600her, loading and preparing them map, calling the provided $check callback
1963that 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
1964the new (success) or old (failed) map position. 2602the new (success) or old (failed) map position. In either case, $done will
2603be called at the end of this process.
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 >>.
1965 2607
1966=cut 2608=cut
1967 2609
1968our $GOTOGEN; 2610our $GOTOGEN;
1969 2611
1970sub cf::object::player::goto { 2612sub cf::object::player::goto {
1971 my ($self, $path, $x, $y, $check) = @_; 2613 my ($self, $path, $x, $y, $check, $done) = @_;
1972 2614
1973 # do generation counting so two concurrent goto's will be executed in-order 2615 # do generation counting so two concurrent goto's will be executed in-order
1974 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2616 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1975 2617
1976 $self->enter_link; 2618 $self->enter_link;
1977 2619
1978 (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
1979 my $map = eval { 2642 my $map = eval {
1980 my $map = cf::map::find $path; 2643 my $map = defined $path ? cf::map::find $path : undef;
1981 2644
1982 if ($map) { 2645 if ($map) {
1983 $map = $map->customise_for ($self); 2646 $map = $map->customise_for ($self);
1984 $map = $check->($map) if $check && $map; 2647 $map = $check->($map) if $check && $map;
1985 } else { 2648 } else {
1986 $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);
1987 } 2650 }
1988 2651
1989 $map 2652 $map
1990 }; 2653 };
1991 2654
… …
1996 2659
1997 if ($gen == $self->{_goto_generation}) { 2660 if ($gen == $self->{_goto_generation}) {
1998 delete $self->{_goto_generation}; 2661 delete $self->{_goto_generation};
1999 $self->leave_link ($map, $x, $y); 2662 $self->leave_link ($map, $x, $y);
2000 } 2663 }
2664
2665 $done->() if $done;
2001 })->prio (1); 2666 })->prio (1);
2002} 2667}
2003 2668
2004=item $player_object->enter_exit ($exit_object) 2669=item $player_object->enter_exit ($exit_object)
2005 2670
… …
2025} 2690}
2026 2691
2027sub prepare_random_map { 2692sub prepare_random_map {
2028 my ($exit) = @_; 2693 my ($exit) = @_;
2029 2694
2030 my $guard = cf::lock_acquire "exit_prepare:$exit";
2031
2032 # all this does is basically replace the /! path by 2695 # all this does is basically replace the /! path by
2033 # a new random map path (?random/...) with a seed 2696 # a new random map path (?random/...) with a seed
2034 # that depends on the exit object 2697 # that depends on the exit object
2035 2698
2036 my $rmp = parse_random_map_params $exit->msg; 2699 my $rmp = parse_random_map_params $exit->msg;
… …
2038 if ($exit->map) { 2701 if ($exit->map) {
2039 $rmp->{region} = $exit->region->name; 2702 $rmp->{region} = $exit->region->name;
2040 $rmp->{origin_map} = $exit->map->path; 2703 $rmp->{origin_map} = $exit->map->path;
2041 $rmp->{origin_x} = $exit->x; 2704 $rmp->{origin_x} = $exit->x;
2042 $rmp->{origin_y} = $exit->y; 2705 $rmp->{origin_y} = $exit->y;
2706
2707 $exit->map->touch;
2043 } 2708 }
2044 2709
2045 $rmp->{random_seed} ||= $exit->random_seed; 2710 $rmp->{random_seed} ||= $exit->random_seed;
2046 2711
2047 my $data = cf::to_json $rmp; 2712 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2048 my $md5 = Digest::MD5::md5_hex $data; 2713 my $md5 = Digest::MD5::md5_hex $data;
2049 my $meta = "$RANDOMDIR/$md5.meta"; 2714 my $meta = "$RANDOMDIR/$md5.meta";
2050 2715
2051 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2716 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2052 aio_write $fh, 0, (length $data), $data, 0; 2717 aio_write $fh, 0, (length $data), $data, 0;
2053 undef $fh; 2718 undef $fh;
2054 aio_rename "$meta~", $meta; 2719 aio_rename "$meta~", $meta;
2055 2720
2721 my $slaying = "?random/$md5";
2722
2723 if ($exit->valid) {
2056 $exit->slaying ("?random/$md5"); 2724 $exit->slaying ("?random/$md5");
2057 $exit->msg (undef); 2725 $exit->msg (undef);
2726 }
2058 } 2727 }
2059} 2728}
2060 2729
2061sub cf::object::player::enter_exit { 2730sub cf::object::player::enter_exit {
2062 my ($self, $exit) = @_; 2731 my ($self, $exit) = @_;
2063 2732
2064 return unless $self->type == cf::PLAYER; 2733 return unless $self->type == cf::PLAYER;
2065 2734
2066 if ($exit->slaying eq "/!") {
2067 #TODO: this should de-fi-ni-te-ly not be a sync-job
2068 # the problem is that $exit might not survive long enough
2069 # so it needs to be done right now, right here
2070 cf::sync_job { prepare_random_map $exit };
2071 }
2072
2073 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2074 my $hp = $exit->stats->hp;
2075 my $sp = $exit->stats->sp;
2076
2077 $self->enter_link; 2735 $self->enter_link;
2078 2736
2079 (async { 2737 (async {
2080 $self->deactivate_recursive; # just to be sure 2738 $Coro::current->{desc} = "enter_exit";
2739
2081 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
2082 $self->goto ($slaying, $hp, $sp); 2755 $self->goto ($map, $x, $y);
2083 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
2084 1; 2761 1
2085 }) { 2762 }) {
2086 $self->message ("Something went wrong deep within the crossfire server. " 2763 $self->message ("Something went wrong deep within the deliantra server. "
2087 . "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. "
2088 . "Please report this to the dungeon master!", 2765 . "Please report this to the dungeon master!",
2089 cf::NDI_UNIQUE | cf::NDI_RED); 2766 cf::NDI_UNIQUE | cf::NDI_RED);
2090 2767
2091 warn "ERROR in enter_exit: $@"; 2768 warn "ERROR in enter_exit: $@";
… …
2110 2787
2111 utf8::encode $text; 2788 utf8::encode $text;
2112 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2789 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2113} 2790}
2114 2791
2792=item $client->send_big_packet ($pkt)
2793
2794Like C<send_packet>, but tries to compress large packets, and fragments
2795them as required.
2796
2797=cut
2798
2799our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2800
2801sub cf::client::send_big_packet {
2802 my ($self, $pkt) = @_;
2803
2804 # try lzf for large packets
2805 $pkt = "lzf " . Compress::LZF::compress $pkt
2806 if 1024 <= length $pkt and $self->{can_lzf};
2807
2808 # split very large packets
2809 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2810 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2811 $pkt = "frag";
2812 }
2813
2814 $self->send_packet ($pkt);
2815}
2816
2817=item $client->send_msg ($channel, $msg, $color, [extra...])
2818
2819Send a drawinfo or msg packet to the client, formatting the msg for the
2820client if neccessary. C<$type> should be a string identifying the type of
2821the message, with C<log> being the default. If C<$color> is negative, suppress
2822the message unless the client supports the msg packet.
2823
2824=cut
2825
2826# non-persistent channels (usually the info channel)
2827our %CHANNEL = (
2828 "c/motd" => {
2829 id => "infobox",
2830 title => "MOTD",
2831 reply => undef,
2832 tooltip => "The message of the day",
2833 },
2834 "c/identify" => {
2835 id => "infobox",
2836 title => "Identify",
2837 reply => undef,
2838 tooltip => "Items recently identified",
2839 },
2840 "c/examine" => {
2841 id => "infobox",
2842 title => "Examine",
2843 reply => undef,
2844 tooltip => "Signs and other items you examined",
2845 },
2846 "c/shopinfo" => {
2847 id => "infobox",
2848 title => "Shop Info",
2849 reply => undef,
2850 tooltip => "What your bargaining skill tells you about the shop",
2851 },
2852 "c/book" => {
2853 id => "infobox",
2854 title => "Book",
2855 reply => undef,
2856 tooltip => "The contents of a note or book",
2857 },
2858 "c/lookat" => {
2859 id => "infobox",
2860 title => "Look",
2861 reply => undef,
2862 tooltip => "What you saw there",
2863 },
2864 "c/who" => {
2865 id => "infobox",
2866 title => "Players",
2867 reply => undef,
2868 tooltip => "Shows players who are currently online",
2869 },
2870 "c/body" => {
2871 id => "infobox",
2872 title => "Body Parts",
2873 reply => undef,
2874 tooltip => "Shows which body parts you posess and are available",
2875 },
2876 "c/statistics" => {
2877 id => "infobox",
2878 title => "Statistics",
2879 reply => undef,
2880 tooltip => "Shows your primary statistics",
2881 },
2882 "c/skills" => {
2883 id => "infobox",
2884 title => "Skills",
2885 reply => undef,
2886 tooltip => "Shows your experience per skill and item power",
2887 },
2888 "c/shopitems" => {
2889 id => "infobox",
2890 title => "Shop Items",
2891 reply => undef,
2892 tooltip => "Shows the items currently for sale in this shop",
2893 },
2894 "c/resistances" => {
2895 id => "infobox",
2896 title => "Resistances",
2897 reply => undef,
2898 tooltip => "Shows your resistances",
2899 },
2900 "c/pets" => {
2901 id => "infobox",
2902 title => "Pets",
2903 reply => undef,
2904 tooltip => "Shows information abotu your pets/a specific pet",
2905 },
2906 "c/perceiveself" => {
2907 id => "infobox",
2908 title => "Perceive Self",
2909 reply => undef,
2910 tooltip => "You gained detailed knowledge about yourself",
2911 },
2912 "c/uptime" => {
2913 id => "infobox",
2914 title => "Uptime",
2915 reply => undef,
2916 tooltip => "How long the server has been running since last restart",
2917 },
2918 "c/mapinfo" => {
2919 id => "infobox",
2920 title => "Map Info",
2921 reply => undef,
2922 tooltip => "Information related to the maps",
2923 },
2924 "c/party" => {
2925 id => "party",
2926 title => "Party",
2927 reply => "gsay ",
2928 tooltip => "Messages and chat related to your party",
2929 },
2930 "c/death" => {
2931 id => "death",
2932 title => "Death",
2933 reply => undef,
2934 tooltip => "Reason for and more info about your most recent death",
2935 },
2936 "c/say" => $SAY_CHANNEL,
2937 "c/chat" => $CHAT_CHANNEL,
2938);
2939
2940sub cf::client::send_msg {
2941 my ($self, $channel, $msg, $color, @extra) = @_;
2942
2943 $msg = $self->pl->expand_cfpod ($msg)
2944 unless $color & cf::NDI_VERBATIM;
2945
2946 $color &= cf::NDI_CLIENT_MASK; # just in case...
2947
2948 # check predefined channels, for the benefit of C
2949 if ($CHANNEL{$channel}) {
2950 $channel = $CHANNEL{$channel};
2951
2952 $self->ext_msg (channel_info => $channel);
2953 $channel = $channel->{id};
2954
2955 } elsif (ref $channel) {
2956 # send meta info to client, if not yet sent
2957 unless (exists $self->{channel}{$channel->{id}}) {
2958 $self->{channel}{$channel->{id}} = $channel;
2959 $self->ext_msg (channel_info => $channel);
2960 }
2961
2962 $channel = $channel->{id};
2963 }
2964
2965 return unless @extra || length $msg;
2966
2967 # default colour, mask it out
2968 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2969 if $color & cf::NDI_DEF;
2970
2971 my $pkt = "msg "
2972 . $self->{json_coder}->encode (
2973 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2974 );
2975
2976 $self->send_big_packet ($pkt);
2977}
2978
2115=item $client->ext_event ($type, %msg) 2979=item $client->ext_msg ($type, @msg)
2116 2980
2117Sends an exti event to the client. 2981Sends an ext event to the client.
2118 2982
2119=cut 2983=cut
2120 2984
2121sub cf::client::ext_event($$%) { 2985sub cf::client::ext_msg($$@) {
2122 my ($self, $type, %msg) = @_; 2986 my ($self, $type, @msg) = @_;
2123 2987
2988 if ($self->extcmd == 2) {
2989 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2990 } elsif ($self->extcmd == 1) { # TODO: remove
2124 $msg{msgtype} = "event_$type"; 2991 push @msg, msgtype => "event_$type";
2125 $self->send_packet ("ext " . cf::to_json \%msg); 2992 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2993 }
2994}
2995
2996=item $client->ext_reply ($msgid, @msg)
2997
2998Sends an ext reply to the client.
2999
3000=cut
3001
3002sub cf::client::ext_reply($$@) {
3003 my ($self, $id, @msg) = @_;
3004
3005 if ($self->extcmd == 2) {
3006 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3007 } elsif ($self->extcmd == 1) {
3008 #TODO: version 1, remove
3009 unshift @msg, msgtype => "reply", msgid => $id;
3010 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3011 }
2126} 3012}
2127 3013
2128=item $success = $client->query ($flags, "text", \&cb) 3014=item $success = $client->query ($flags, "text", \&cb)
2129 3015
2130Queues a query to the client, calling the given callback with 3016Queues a query to the client, calling the given callback with
2131the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 3017the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2132C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 3018C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2133 3019
2134Queries can fail, so check the return code. Or don't, as queries will become 3020Queries can fail, so check the return code. Or don't, as queries will
2135reliable at some point in the future. 3021become reliable at some point in the future.
2136 3022
2137=cut 3023=cut
2138 3024
2139sub cf::client::query { 3025sub cf::client::query {
2140 my ($self, $flags, $text, $cb) = @_; 3026 my ($self, $flags, $text, $cb) = @_;
… …
2148 utf8::encode $text; 3034 utf8::encode $text;
2149 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3035 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2150 3036
2151 $self->send_packet ($self->{query_queue}[0][0]) 3037 $self->send_packet ($self->{query_queue}[0][0])
2152 if @{ $self->{query_queue} } == 1; 3038 if @{ $self->{query_queue} } == 1;
3039
3040 1
2153} 3041}
2154 3042
2155cf::client->attach ( 3043cf::client->attach (
3044 on_connect => sub {
3045 my ($ns) = @_;
3046
3047 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3048 },
2156 on_reply => sub { 3049 on_reply => sub {
2157 my ($ns, $msg) = @_; 3050 my ($ns, $msg) = @_;
2158 3051
2159 # this weird shuffling is so that direct followup queries 3052 # this weird shuffling is so that direct followup queries
2160 # get handled first 3053 # get handled first
… …
2172 } else { 3065 } else {
2173 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3066 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2174 } 3067 }
2175 } 3068 }
2176 }, 3069 },
3070 on_exticmd => sub {
3071 my ($ns, $buf) = @_;
3072
3073 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3074
3075 if (ref $msg) {
3076 my ($type, $reply, @payload) =
3077 "ARRAY" eq ref $msg
3078 ? @$msg
3079 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3080
3081 my @reply;
3082
3083 if (my $cb = $EXTICMD{$type}) {
3084 @reply = $cb->($ns, @payload);
3085 }
3086
3087 $ns->ext_reply ($reply, @reply)
3088 if $reply;
3089
3090 } else {
3091 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3092 }
3093
3094 cf::override;
3095 },
2177); 3096);
2178 3097
2179=item $client->async (\&cb) 3098=item $client->async (\&cb)
2180 3099
2181Create a new coroutine, running the specified callback. The coroutine will 3100Create a new coroutine, running the specified callback. The coroutine will
… …
2222our $safe = new Safe "safe"; 3141our $safe = new Safe "safe";
2223our $safe_hole = new Safe::Hole; 3142our $safe_hole = new Safe::Hole;
2224 3143
2225$SIG{FPE} = 'IGNORE'; 3144$SIG{FPE} = 'IGNORE';
2226 3145
2227$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3146$safe->permit_only (Opcode::opset qw(
3147 :base_core :base_mem :base_orig :base_math
3148 grepstart grepwhile mapstart mapwhile
3149 sort time
3150));
2228 3151
2229# here we export the classes and methods available to script code 3152# here we export the classes and methods available to script code
2230 3153
2231=pod 3154=pod
2232 3155
2233The following functions and methods are available within a safe environment: 3156The following functions and methods are available within a safe environment:
2234 3157
2235 cf::object contr pay_amount pay_player map 3158 cf::object
3159 contr pay_amount pay_player map x y force_find force_add destroy
3160 insert remove name archname title slaying race decrease split
3161 value
3162
2236 cf::object::player player 3163 cf::object::player
2237 cf::player peaceful 3164 player
2238 cf::map trigger 3165
3166 cf::player
3167 peaceful
3168
3169 cf::map
3170 trigger
2239 3171
2240=cut 3172=cut
2241 3173
2242for ( 3174for (
2243 ["cf::object" => qw(contr pay_amount pay_player map)], 3175 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3176 insert remove inv nrof name archname title slaying race
3177 decrease split destroy change_exp value msg lore send_msg)],
2244 ["cf::object::player" => qw(player)], 3178 ["cf::object::player" => qw(player)],
2245 ["cf::player" => qw(peaceful)], 3179 ["cf::player" => qw(peaceful send_msg)],
2246 ["cf::map" => qw(trigger)], 3180 ["cf::map" => qw(trigger)],
2247) { 3181) {
2248 no strict 'refs'; 3182 no strict 'refs';
2249 my ($pkg, @funs) = @$_; 3183 my ($pkg, @funs) = @$_;
2250 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3184 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
2267 my ($code, %vars) = @_; 3201 my ($code, %vars) = @_;
2268 3202
2269 my $qcode = $code; 3203 my $qcode = $code;
2270 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3204 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2271 $qcode =~ s/\n/\\n/g; 3205 $qcode =~ s/\n/\\n/g;
3206
3207 %vars = (_dummy => 0) unless %vars;
2272 3208
2273 local $_; 3209 local $_;
2274 local @safe::cf::_safe_eval_args = values %vars; 3210 local @safe::cf::_safe_eval_args = values %vars;
2275 3211
2276 my $eval = 3212 my $eval =
… …
2319=back 3255=back
2320 3256
2321=cut 3257=cut
2322 3258
2323############################################################################# 3259#############################################################################
2324
2325=head2 EXTENSION DATABASE SUPPORT
2326
2327Crossfire maintains a very simple database for extension use. It can
2328currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2329convert to/from binary).
2330
2331The parameter C<$family> should best start with the name of the extension
2332using it, it should be unique.
2333
2334=over 4
2335
2336=item $value = cf::db_get $family => $key
2337
2338Returns a single value from the database.
2339
2340=item cf::db_put $family => $key => $value
2341
2342Stores the given C<$value> in the family.
2343
2344=cut
2345
2346our $DB;
2347
2348sub db_init {
2349 unless ($DB) {
2350 $DB = BDB::db_create $DB_ENV;
2351
2352 cf::sync_job {
2353 eval {
2354 $DB->set_flags (BDB::CHKSUM);
2355
2356 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2357 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2358 cf::cleanup "db_open(db): $!" if $!;
2359 };
2360 cf::cleanup "db_open(db): $@" if $@;
2361 };
2362 }
2363}
2364
2365sub db_get($$) {
2366 my $key = "$_[0]/$_[1]";
2367
2368 cf::sync_job {
2369 BDB::db_get $DB, undef, $key, my $data;
2370
2371 $! ? ()
2372 : $data
2373 }
2374}
2375
2376sub db_put($$$) {
2377 BDB::dbreq_pri 4;
2378 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2379}
2380
2381=item cf::cache $id => [$paths...], $processversion => $process
2382
2383Generic caching function that returns the value of the resource $id,
2384caching and regenerating as required.
2385
2386This function can block.
2387
2388=cut
2389
2390sub cache {
2391 my ($id, $src, $processversion, $process) = @_;
2392
2393 my $meta =
2394 join "\x00",
2395 $processversion,
2396 map {
2397 aio_stat $_
2398 and Carp::croak "$_: $!";
2399
2400 ($_, (stat _)[7,9])
2401 } @$src;
2402
2403 my $dbmeta = db_get cache => "$id/meta";
2404 if ($dbmeta ne $meta) {
2405 # changed, we may need to process
2406
2407 my @data;
2408 my $md5;
2409
2410 for (0 .. $#$src) {
2411 0 <= aio_load $src->[$_], $data[$_]
2412 or Carp::croak "$src->[$_]: $!";
2413 }
2414
2415 # if processing is expensive, check
2416 # checksum first
2417 if (1) {
2418 $md5 =
2419 join "\x00",
2420 $processversion,
2421 map {
2422 Coro::cede;
2423 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2424 } 0.. $#$src;
2425
2426
2427 my $dbmd5 = db_get cache => "$id/md5";
2428 if ($dbmd5 eq $md5) {
2429 db_put cache => "$id/meta", $meta;
2430
2431 return db_get cache => "$id/data";
2432 }
2433 }
2434
2435 my $t1 = Time::HiRes::time;
2436 my $data = $process->(\@data);
2437 my $t2 = Time::HiRes::time;
2438
2439 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2440
2441 db_put cache => "$id/data", $data;
2442 db_put cache => "$id/md5" , $md5;
2443 db_put cache => "$id/meta", $meta;
2444
2445 return $data;
2446 }
2447
2448 db_get cache => "$id/data"
2449}
2450
2451=item fork_call { }, $args
2452
2453Executes the given code block with the given arguments in a seperate
2454process, returning the results. Everything must be serialisable with
2455Coro::Storable. May, of course, block. Note that the executed sub may
2456never block itself or use any form of Event handling.
2457
2458=cut
2459
2460sub fork_call(&@) {
2461 my ($cb, @args) = @_;
2462
2463# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2464# or die "socketpair: $!";
2465 pipe my $fh1, my $fh2
2466 or die "pipe: $!";
2467
2468 if (my $pid = fork) {
2469 close $fh2;
2470
2471 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2472 $res = Coro::Storable::thaw $res;
2473
2474 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2475
2476 die $$res unless "ARRAY" eq ref $res;
2477
2478 return wantarray ? @$res : $res->[-1];
2479 } else {
2480 reset_signals;
2481 local $SIG{__WARN__};
2482 local $SIG{__DIE__};
2483 eval {
2484 close $fh1;
2485
2486 my @res = eval { $cb->(@args) };
2487 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2488 };
2489
2490 warn $@ if $@;
2491 _exit 0;
2492 }
2493}
2494
2495#############################################################################
2496# the server's init and main functions 3260# the server's init and main functions
2497 3261
2498sub load_facedata($) { 3262sub load_facedata($) {
2499 my ($path) = @_; 3263 my ($path) = @_;
3264
3265 # HACK to clear player env face cache, we need some signal framework
3266 # for this (global event?)
3267 %ext::player_env::MUSIC_FACE_CACHE = ();
3268
3269 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2500 3270
2501 warn "loading facedata from $path\n"; 3271 warn "loading facedata from $path\n";
2502 3272
2503 my $facedata; 3273 my $facedata;
2504 0 < aio_load $path, $facedata 3274 0 < aio_load $path, $facedata
… …
2507 $facedata = Coro::Storable::thaw $facedata; 3277 $facedata = Coro::Storable::thaw $facedata;
2508 3278
2509 $facedata->{version} == 2 3279 $facedata->{version} == 2
2510 or cf::cleanup "$path: version mismatch, cannot proceed."; 3280 or cf::cleanup "$path: version mismatch, cannot proceed.";
2511 3281
3282 # patch in the exptable
3283 $facedata->{resource}{"res/exp_table"} = {
3284 type => FT_RSRC,
3285 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3286 };
3287 cf::cede_to_tick;
3288
2512 { 3289 {
2513 my $faces = $facedata->{faceinfo}; 3290 my $faces = $facedata->{faceinfo};
2514 3291
2515 while (my ($face, $info) = each %$faces) { 3292 while (my ($face, $info) = each %$faces) {
2516 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3293 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3294
2517 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3295 cf::face::set_visibility $idx, $info->{visibility};
3296 cf::face::set_magicmap $idx, $info->{magicmap};
2518 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3297 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2519 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3298 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2520 Coro::cede; 3299
3300 cf::cede_to_tick;
2521 } 3301 }
2522 3302
2523 while (my ($face, $info) = each %$faces) { 3303 while (my ($face, $info) = each %$faces) {
2524 next unless $info->{smooth}; 3304 next unless $info->{smooth};
3305
2525 my $idx = cf::face::find $face 3306 my $idx = cf::face::find $face
2526 or next; 3307 or next;
3308
2527 if (my $smooth = cf::face::find $info->{smooth}) { 3309 if (my $smooth = cf::face::find $info->{smooth}) {
3310 cf::face::set_smooth $idx, $smooth;
2528 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3311 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2529 } else { 3312 } else {
2530 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3313 warn "smooth face '$info->{smooth}' not found for face '$face'";
2531 } 3314 }
2532 Coro::cede; 3315
3316 cf::cede_to_tick;
2533 } 3317 }
2534 } 3318 }
2535 3319
2536 { 3320 {
2537 my $anims = $facedata->{animinfo}; 3321 my $anims = $facedata->{animinfo};
2538 3322
2539 while (my ($anim, $info) = each %$anims) { 3323 while (my ($anim, $info) = each %$anims) {
2540 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3324 cf::anim::set $anim, $info->{frames}, $info->{facings};
2541 Coro::cede; 3325 cf::cede_to_tick;
2542 } 3326 }
2543 3327
2544 cf::anim::invalidate_all; # d'oh 3328 cf::anim::invalidate_all; # d'oh
2545 } 3329 }
2546 3330
3331 {
3332 # TODO: for gcfclient pleasure, we should give resources
3333 # that gcfclient doesn't grok a >10000 face index.
3334 my $res = $facedata->{resource};
3335
3336 while (my ($name, $info) = each %$res) {
3337 if (defined $info->{type}) {
3338 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3339 my $data;
3340
3341 if ($info->{type} & 1) {
3342 # prepend meta info
3343
3344 my $meta = $enc->encode ({
3345 name => $name,
3346 %{ $info->{meta} || {} },
3347 });
3348
3349 $data = pack "(w/a*)*", $meta, $info->{data};
3350 } else {
3351 $data = $info->{data};
3352 }
3353
3354 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3355 cf::face::set_type $idx, $info->{type};
3356 } else {
3357 $RESOURCE{$name} = $info;
3358 }
3359
3360 cf::cede_to_tick;
3361 }
3362 }
3363
3364 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3365
2547 1 3366 1
2548} 3367}
2549 3368
3369cf::global->attach (on_resource_update => sub {
3370 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3371 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3372
3373 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3374 my $sound = $soundconf->{compat}[$_]
3375 or next;
3376
3377 my $face = cf::face::find "sound/$sound->[1]";
3378 cf::sound::set $sound->[0] => $face;
3379 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3380 }
3381
3382 while (my ($k, $v) = each %{$soundconf->{event}}) {
3383 my $face = cf::face::find "sound/$v";
3384 cf::sound::set $k => $face;
3385 }
3386 }
3387});
3388
3389register_exticmd fx_want => sub {
3390 my ($ns, $want) = @_;
3391
3392 while (my ($k, $v) = each %$want) {
3393 $ns->fx_want ($k, $v);
3394 }
3395};
3396
3397sub load_resource_file($) {
3398 my $guard = lock_acquire "load_resource_file";
3399
3400 my $status = load_resource_file_ $_[0];
3401 get_slot 0.1, 100;
3402 cf::arch::commit_load;
3403
3404 $status
3405}
3406
2550sub reload_regions { 3407sub reload_regions {
3408 # HACK to clear player env face cache, we need some signal framework
3409 # for this (global event?)
3410 %ext::player_env::MUSIC_FACE_CACHE = ();
3411
2551 load_resource_file "$MAPDIR/regions" 3412 load_resource_file "$MAPDIR/regions"
2552 or die "unable to load regions file\n"; 3413 or die "unable to load regions file\n";
3414
3415 for (cf::region::list) {
3416 $_->{match} = qr/$_->{match}/
3417 if exists $_->{match};
3418 }
2553} 3419}
2554 3420
2555sub reload_facedata { 3421sub reload_facedata {
2556 load_facedata "$DATADIR/facedata" 3422 load_facedata "$DATADIR/facedata"
2557 or die "unable to load facedata\n"; 3423 or die "unable to load facedata\n";
… …
2568} 3434}
2569 3435
2570sub reload_resources { 3436sub reload_resources {
2571 warn "reloading resource files...\n"; 3437 warn "reloading resource files...\n";
2572 3438
3439 reload_facedata;
3440 reload_archetypes;
2573 reload_regions; 3441 reload_regions;
2574 reload_facedata;
2575 #reload_archetypes;#d#
2576 reload_archetypes;
2577 reload_treasures; 3442 reload_treasures;
2578 3443
2579 warn "finished reloading resource files\n"; 3444 warn "finished reloading resource files\n";
2580} 3445}
2581 3446
2582sub init { 3447sub reload_config {
2583 reload_resources; 3448 warn "reloading config file...\n";
2584}
2585 3449
2586sub cfg_load {
2587 open my $fh, "<:utf8", "$CONFDIR/config" 3450 open my $fh, "<:utf8", "$CONFDIR/config"
2588 or return; 3451 or return;
2589 3452
2590 local $/; 3453 local $/;
2591 *CFG = YAML::Syck::Load <$fh>; 3454 *CFG = YAML::XS::Load scalar <$fh>;
2592 3455
2593 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3456 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2594 3457
2595 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3458 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2596 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3459 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
2600 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3463 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2601 and die "WARNING: m(un)lockall failed: $!\n"; 3464 and die "WARNING: m(un)lockall failed: $!\n";
2602 }; 3465 };
2603 warn $@ if $@; 3466 warn $@ if $@;
2604 } 3467 }
3468
3469 warn "finished reloading resource files\n";
3470}
3471
3472sub pidfile() {
3473 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3474 or die "$PIDFILE: $!";
3475 flock $fh, &Fcntl::LOCK_EX
3476 or die "$PIDFILE: flock: $!";
3477 $fh
3478}
3479
3480# make sure only one server instance is running at any one time
3481sub atomic {
3482 my $fh = pidfile;
3483
3484 my $pid = <$fh>;
3485 kill 9, $pid if $pid > 0;
3486
3487 seek $fh, 0, 0;
3488 print $fh $$;
3489}
3490
3491sub main_loop {
3492 warn "EV::loop starting\n";
3493 if (1) {
3494 EV::loop;
3495 }
3496 warn "EV::loop returned\n";
3497 goto &main_loop unless $REALLY_UNLOOP;
2605} 3498}
2606 3499
2607sub main { 3500sub main {
3501 cf::init_globals; # initialise logging
3502
3503 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3504 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3505 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3506 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3507
3508 cf::init_experience;
3509 cf::init_anim;
3510 cf::init_attackmess;
3511 cf::init_dynamic;
3512
3513 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3514
2608 # we must not ever block the main coroutine 3515 # we must not ever block the main coroutine
2609 local $Coro::idle = sub { 3516 local $Coro::idle = sub {
2610 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3517 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2611 (async { 3518 (async {
2612 Event::one_event; 3519 $Coro::current->{desc} = "IDLE BUG HANDLER";
3520 EV::loop EV::LOOP_ONESHOT;
2613 })->prio (Coro::PRIO_MAX); 3521 })->prio (Coro::PRIO_MAX);
2614 }; 3522 };
2615 3523
2616 cfg_load; 3524 evthread_start IO::AIO::poll_fileno;
3525
3526 cf::sync_job {
3527 cf::load_settings;
3528 cf::load_materials;
3529
3530 reload_resources;
3531 reload_config;
2617 db_init; 3532 db_init;
3533
3534 cf::init_uuid;
3535 cf::init_signals;
3536 cf::init_commands;
3537 cf::init_skills;
3538
3539 cf::init_beforeplay;
3540
3541 atomic;
3542
2618 load_extensions; 3543 load_extensions;
2619 3544
2620 $TICK_WATCHER->start; 3545 utime time, time, $RUNTIMEFILE;
2621 Event::loop; 3546
3547 # no (long-running) fork's whatsoever before this point(!)
3548 use POSIX ();
3549 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3550
3551 (pop @POST_INIT)->(0) while @POST_INIT;
3552 };
3553
3554 main_loop;
2622} 3555}
2623 3556
2624############################################################################# 3557#############################################################################
2625# initialisation and cleanup 3558# initialisation and cleanup
2626 3559
2627# install some emergency cleanup handlers 3560# install some emergency cleanup handlers
2628BEGIN { 3561BEGIN {
3562 our %SIGWATCHER = ();
2629 for my $signal (qw(INT HUP TERM)) { 3563 for my $signal (qw(INT HUP TERM)) {
2630 Event->signal ( 3564 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2631 reentrant => 0,
2632 data => WF_AUTOCANCEL,
2633 signal => $signal,
2634 prio => 0,
2635 cb => sub {
2636 cf::cleanup "SIG$signal"; 3565 cf::cleanup "SIG$signal";
2637 },
2638 ); 3566 };
3567 }
3568}
3569
3570sub write_runtime_sync {
3571 # first touch the runtime file to show we are still running:
3572 # the fsync below can take a very very long time.
3573
3574 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3575
3576 my $guard = cf::lock_acquire "write_runtime";
3577
3578 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3579 or return;
3580
3581 my $value = $cf::RUNTIME + 90 + 10;
3582 # 10 is the runtime save interval, for a monotonic clock
3583 # 60 allows for the watchdog to kill the server.
3584
3585 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3586 and return;
3587
3588 # always fsync - this file is important
3589 aio_fsync $fh
3590 and return;
3591
3592 # touch it again to show we are up-to-date
3593 aio_utime $fh, undef, undef;
3594
3595 close $fh
3596 or return;
3597
3598 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3599 and return;
3600
3601 warn "runtime file written.\n";
3602
2639 } 3603 1
3604}
3605
3606our $uuid_lock;
3607our $uuid_skip;
3608
3609sub write_uuid_sync($) {
3610 $uuid_skip ||= $_[0];
3611
3612 return if $uuid_lock;
3613 local $uuid_lock = 1;
3614
3615 my $uuid = "$LOCALDIR/uuid";
3616
3617 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3618 or return;
3619
3620 my $value = uuid_seq uuid_cur;
3621
3622 unless ($value) {
3623 warn "cowardly refusing to write zero uuid value!\n";
3624 return;
3625 }
3626
3627 my $value = uuid_str $value + $uuid_skip;
3628 $uuid_skip = 0;
3629
3630 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3631 and return;
3632
3633 # always fsync - this file is important
3634 aio_fsync $fh
3635 and return;
3636
3637 close $fh
3638 or return;
3639
3640 aio_rename "$uuid~", $uuid
3641 and return;
3642
3643 warn "uuid file written ($value).\n";
3644
3645 1
3646
3647}
3648
3649sub write_uuid($$) {
3650 my ($skip, $sync) = @_;
3651
3652 $sync ? write_uuid_sync $skip
3653 : async { write_uuid_sync $skip };
2640} 3654}
2641 3655
2642sub emergency_save() { 3656sub emergency_save() {
2643 my $freeze_guard = cf::freeze_mainloop; 3657 my $freeze_guard = cf::freeze_mainloop;
2644 3658
2645 warn "enter emergency perl save\n"; 3659 warn "emergency_perl_save: enter\n";
2646 3660
2647 cf::sync_job { 3661 cf::sync_job {
3662 # this is a trade-off: we want to be very quick here, so
3663 # save all maps without fsync, and later call a global sync
3664 # (which in turn might be very very slow)
3665 local $USE_FSYNC = 0;
3666
2648 # use a peculiar iteration method to avoid tripping on perl 3667 # use a peculiar iteration method to avoid tripping on perl
2649 # refcount bugs in for. also avoids problems with players 3668 # refcount bugs in for. also avoids problems with players
2650 # and maps saved/destroyed asynchronously. 3669 # and maps saved/destroyed asynchronously.
2651 warn "begin emergency player save\n"; 3670 warn "emergency_perl_save: begin player save\n";
2652 for my $login (keys %cf::PLAYER) { 3671 for my $login (keys %cf::PLAYER) {
2653 my $pl = $cf::PLAYER{$login} or next; 3672 my $pl = $cf::PLAYER{$login} or next;
2654 $pl->valid or next; 3673 $pl->valid or next;
3674 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2655 $pl->save; 3675 $pl->save;
2656 } 3676 }
2657 warn "end emergency player save\n"; 3677 warn "emergency_perl_save: end player save\n";
2658 3678
2659 warn "begin emergency map save\n"; 3679 warn "emergency_perl_save: begin map save\n";
2660 for my $path (keys %cf::MAP) { 3680 for my $path (keys %cf::MAP) {
2661 my $map = $cf::MAP{$path} or next; 3681 my $map = $cf::MAP{$path} or next;
2662 $map->valid or next; 3682 $map->valid or next;
2663 $map->save; 3683 $map->save;
2664 } 3684 }
2665 warn "end emergency map save\n"; 3685 warn "emergency_perl_save: end map save\n";
2666 3686
2667 warn "begin emergency database checkpoint\n"; 3687 warn "emergency_perl_save: begin database checkpoint\n";
2668 BDB::db_env_txn_checkpoint $DB_ENV; 3688 BDB::db_env_txn_checkpoint $DB_ENV;
2669 warn "end emergency database checkpoint\n"; 3689 warn "emergency_perl_save: end database checkpoint\n";
3690
3691 warn "emergency_perl_save: begin write uuid\n";
3692 write_uuid_sync 1;
3693 warn "emergency_perl_save: end write uuid\n";
2670 }; 3694 };
2671 3695
3696 warn "emergency_perl_save: starting sync()\n";
3697 IO::AIO::aio_sync sub {
3698 warn "emergency_perl_save: finished sync()\n";
3699 };
3700
2672 warn "leave emergency perl save\n"; 3701 warn "emergency_perl_save: leave\n";
2673} 3702}
2674 3703
2675sub post_cleanup { 3704sub post_cleanup {
2676 my ($make_core) = @_; 3705 my ($make_core) = @_;
2677 3706
2678 warn Carp::longmess "post_cleanup backtrace" 3707 warn Carp::longmess "post_cleanup backtrace"
2679 if $make_core; 3708 if $make_core;
3709
3710 my $fh = pidfile;
3711 unlink $PIDFILE if <$fh> == $$;
3712}
3713
3714# a safer delete_package, copied from Symbol
3715sub clear_package($) {
3716 my $pkg = shift;
3717
3718 # expand to full symbol table name if needed
3719 unless ($pkg =~ /^main::.*::$/) {
3720 $pkg = "main$pkg" if $pkg =~ /^::/;
3721 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3722 $pkg .= '::' unless $pkg =~ /::$/;
3723 }
3724
3725 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3726 my $stem_symtab = *{$stem}{HASH};
3727
3728 defined $stem_symtab and exists $stem_symtab->{$leaf}
3729 or return;
3730
3731 # clear all symbols
3732 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3733 for my $name (keys %$leaf_symtab) {
3734 _gv_clear *{"$pkg$name"};
3735# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3736 }
3737 warn "cleared package $pkg\n";#d#
2680} 3738}
2681 3739
2682sub do_reload_perl() { 3740sub do_reload_perl() {
2683 # can/must only be called in main 3741 # can/must only be called in main
2684 if ($Coro::current != $Coro::main) { 3742 if ($Coro::current != $Coro::main) {
2685 warn "can only reload from main coroutine"; 3743 warn "can only reload from main coroutine";
2686 return; 3744 return;
2687 } 3745 }
2688 3746
3747 return if $RELOAD++;
3748
3749 my $t1 = EV::time;
3750
3751 while ($RELOAD) {
2689 warn "reloading..."; 3752 warn "reloading...";
2690 3753
2691 warn "entering sync_job"; 3754 warn "entering sync_job";
2692 3755
2693 cf::sync_job { 3756 cf::sync_job {
2694 cf::write_runtime; # external watchdog should not bark 3757 cf::write_runtime_sync; # external watchdog should not bark
2695 cf::emergency_save; 3758 cf::emergency_save;
2696 cf::write_runtime; # external watchdog should not bark 3759 cf::write_runtime_sync; # external watchdog should not bark
2697 3760
2698 warn "syncing database to disk"; 3761 warn "syncing database to disk";
2699 BDB::db_env_txn_checkpoint $DB_ENV; 3762 BDB::db_env_txn_checkpoint $DB_ENV;
2700 3763
2701 # if anything goes wrong in here, we should simply crash as we already saved 3764 # if anything goes wrong in here, we should simply crash as we already saved
2702 3765
2703 warn "cancelling all WF_AUTOCANCEL watchers";
2704 for (Event::all_watchers) {
2705 $_->cancel if $_->data & WF_AUTOCANCEL;
2706 }
2707
2708 warn "flushing outstanding aio requests"; 3766 warn "flushing outstanding aio requests";
2709 for (;;) {
2710 BDB::flush;
2711 IO::AIO::flush;
2712 Coro::cede;
2713 last unless IO::AIO::nreqs || BDB::nreqs; 3767 while (IO::AIO::nreqs || BDB::nreqs) {
2714 warn "iterate..."; 3768 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2715 }
2716
2717 ++$RELOAD;
2718
2719 warn "cancelling all extension coros";
2720 $_->cancel for values %EXT_CORO;
2721 %EXT_CORO = ();
2722
2723 warn "removing commands";
2724 %COMMAND = ();
2725
2726 warn "removing ext commands";
2727 %EXTCMD = ();
2728
2729 warn "unloading/nuking all extensions";
2730 for my $pkg (@EXTS) {
2731 warn "... unloading $pkg";
2732
2733 if (my $cb = $pkg->can ("unload")) {
2734 eval {
2735 $cb->($pkg);
2736 1
2737 } or warn "$pkg unloaded, but with errors: $@";
2738 } 3769 }
2739 3770
2740 warn "... nuking $pkg"; 3771 warn "cancelling all extension coros";
2741 Symbol::delete_package $pkg; 3772 $_->cancel for values %EXT_CORO;
2742 } 3773 %EXT_CORO = ();
2743 3774
2744 warn "unloading all perl modules loaded from $LIBDIR"; 3775 warn "removing commands";
2745 while (my ($k, $v) = each %INC) { 3776 %COMMAND = ();
2746 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2747 3777
3778 warn "removing ext/exti commands";
3779 %EXTCMD = ();
3780 %EXTICMD = ();
3781
3782 warn "unloading/nuking all extensions";
3783 for my $pkg (@EXTS) {
2748 warn "... unloading $k"; 3784 warn "... unloading $pkg";
2749 delete $INC{$k};
2750 3785
2751 $k =~ s/\.pm$//;
2752 $k =~ s/\//::/g;
2753
2754 if (my $cb = $k->can ("unload_module")) { 3786 if (my $cb = $pkg->can ("unload")) {
3787 eval {
2755 $cb->(); 3788 $cb->($pkg);
3789 1
3790 } or warn "$pkg unloaded, but with errors: $@";
3791 }
3792
3793 warn "... clearing $pkg";
3794 clear_package $pkg;
2756 } 3795 }
2757 3796
2758 Symbol::delete_package $k; 3797 warn "unloading all perl modules loaded from $LIBDIR";
3798 while (my ($k, $v) = each %INC) {
3799 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3800
3801 warn "... unloading $k";
3802 delete $INC{$k};
3803
3804 $k =~ s/\.pm$//;
3805 $k =~ s/\//::/g;
3806
3807 if (my $cb = $k->can ("unload_module")) {
3808 $cb->();
3809 }
3810
3811 clear_package $k;
2759 } 3812 }
2760 3813
2761 warn "getting rid of safe::, as good as possible"; 3814 warn "getting rid of safe::, as good as possible";
2762 Symbol::delete_package "safe::$_" 3815 clear_package "safe::$_"
2763 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3816 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2764 3817
2765 warn "unloading cf.pm \"a bit\""; 3818 warn "unloading cf.pm \"a bit\"";
2766 delete $INC{"cf.pm"}; 3819 delete $INC{"cf.pm"};
2767 delete $INC{"cf/pod.pm"}; 3820 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2768 3821
2769 # don't, removes xs symbols, too, 3822 # don't, removes xs symbols, too,
2770 # and global variables created in xs 3823 # and global variables created in xs
2771 #Symbol::delete_package __PACKAGE__; 3824 #clear_package __PACKAGE__;
2772 3825
2773 warn "unload completed, starting to reload now"; 3826 warn "unload completed, starting to reload now";
2774 3827
2775 warn "reloading cf.pm"; 3828 warn "reloading cf.pm";
2776 require cf; 3829 require cf;
2777 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3830 cf::_connect_to_perl_1;
2778 3831
2779 warn "loading config and database again"; 3832 warn "loading config and database again";
2780 cf::cfg_load; 3833 cf::reload_config;
2781 3834
2782 warn "loading extensions"; 3835 warn "loading extensions";
2783 cf::load_extensions; 3836 cf::load_extensions;
2784 3837
3838 if ($REATTACH_ON_RELOAD) {
2785 warn "reattaching attachments to objects/players"; 3839 warn "reattaching attachments to objects/players";
2786 _global_reattach; # objects, sockets 3840 _global_reattach; # objects, sockets
2787 warn "reattaching attachments to maps"; 3841 warn "reattaching attachments to maps";
2788 reattach $_ for values %MAP; 3842 reattach $_ for values %MAP;
2789 warn "reattaching attachments to players"; 3843 warn "reattaching attachments to players";
2790 reattach $_ for values %PLAYER; 3844 reattach $_ for values %PLAYER;
3845 }
2791 3846
3847 warn "running post_init jobs";
3848 (pop @POST_INIT)->(1) while @POST_INIT;
3849
2792 warn "leaving sync_job"; 3850 warn "leaving sync_job";
2793 3851
2794 1 3852 1
2795 } or do { 3853 } or do {
2796 warn $@; 3854 warn $@;
2797 warn "error while reloading, exiting."; 3855 cf::cleanup "error while reloading, exiting.";
2798 exit 1;
2799 }; 3856 };
2800 3857
2801 warn "reloaded"; 3858 warn "reloaded";
3859 --$RELOAD;
3860 }
3861
3862 $t1 = EV::time - $t1;
3863 warn "reload completed in ${t1}s\n";
2802}; 3864};
2803 3865
2804our $RELOAD_WATCHER; # used only during reload 3866our $RELOAD_WATCHER; # used only during reload
2805 3867
2806sub reload_perl() { 3868sub reload_perl() {
2807 # doing reload synchronously and two reloads happen back-to-back, 3869 # doing reload synchronously and two reloads happen back-to-back,
2808 # coro crashes during coro_state_free->destroy here. 3870 # coro crashes during coro_state_free->destroy here.
2809 3871
2810 $RELOAD_WATCHER ||= Event->timer ( 3872 $RELOAD_WATCHER ||= cf::async {
2811 reentrant => 0, 3873 Coro::AIO::aio_wait cache_extensions;
2812 after => 0, 3874
2813 data => WF_AUTOCANCEL, 3875 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
2814 cb => sub {
2815 do_reload_perl; 3876 do_reload_perl;
2816 undef $RELOAD_WATCHER; 3877 undef $RELOAD_WATCHER;
2817 }, 3878 };
2818 ); 3879 };
2819} 3880}
2820 3881
2821register_command "reload" => sub { 3882register_command "reload" => sub {
2822 my ($who, $arg) = @_; 3883 my ($who, $arg) = @_;
2823 3884
2824 if ($who->flag (FLAG_WIZ)) { 3885 if ($who->flag (FLAG_WIZ)) {
2825 $who->message ("reloading server."); 3886 $who->message ("reloading server.");
3887 async {
3888 $Coro::current->{desc} = "perl_reload";
2826 async { reload_perl }; 3889 reload_perl;
3890 };
2827 } 3891 }
2828}; 3892};
2829 3893
2830unshift @INC, $LIBDIR; 3894unshift @INC, $LIBDIR;
2831 3895
… …
2833 3897
2834our @WAIT_FOR_TICK; 3898our @WAIT_FOR_TICK;
2835our @WAIT_FOR_TICK_BEGIN; 3899our @WAIT_FOR_TICK_BEGIN;
2836 3900
2837sub wait_for_tick { 3901sub wait_for_tick {
2838 return unless $TICK_WATCHER->is_active;
2839 return if $Coro::current == $Coro::main; 3902 return if tick_inhibit || $Coro::current == $Coro::main;
2840 3903
2841 my $signal = new Coro::Signal; 3904 my $signal = new Coro::Signal;
2842 push @WAIT_FOR_TICK, $signal; 3905 push @WAIT_FOR_TICK, $signal;
2843 $signal->wait; 3906 $signal->wait;
2844} 3907}
2845 3908
2846sub wait_for_tick_begin { 3909sub wait_for_tick_begin {
2847 return unless $TICK_WATCHER->is_active;
2848 return if $Coro::current == $Coro::main; 3910 return if tick_inhibit || $Coro::current == $Coro::main;
2849 3911
2850 my $signal = new Coro::Signal; 3912 my $signal = new Coro::Signal;
2851 push @WAIT_FOR_TICK_BEGIN, $signal; 3913 push @WAIT_FOR_TICK_BEGIN, $signal;
2852 $signal->wait; 3914 $signal->wait;
2853} 3915}
2854 3916
2855 my $min = 1e6;#d# 3917sub tick {
2856 my $avg = 10;
2857$TICK_WATCHER = Event->timer (
2858 reentrant => 0,
2859 parked => 1,
2860 prio => 0,
2861 at => $NEXT_TICK || $TICK,
2862 data => WF_AUTOCANCEL,
2863 cb => sub {
2864 if ($Coro::current != $Coro::main) { 3918 if ($Coro::current != $Coro::main) {
2865 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3919 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2866 unless ++$bug_warning > 10; 3920 unless ++$bug_warning > 10;
2867 return; 3921 return;
2868 } 3922 }
2869 3923
2870 $NOW = $tick_start = Event::time;
2871
2872 cf::server_tick; # one server iteration 3924 cf::server_tick; # one server iteration
2873 3925
2874 0 && sync_job {#d# 3926 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2875 for(1..10) { 3927 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2876 my $t = Event::time; 3928 Coro::async_pool {
2877 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3929 $Coro::current->{desc} = "runtime saver";
2878 or die; 3930 write_runtime_sync
2879 3931 or warn "ERROR: unable to write runtime file: $!";
2880 $map->width (50);
2881 $map->height (50);
2882 $map->alloc;
2883 $map->_load_objects ("/tmp/x.map", 1);
2884 my $t = Event::time - $t;
2885
2886 #next unless $t < 0.0013;#d#
2887 if ($t < $min) {
2888 $min = $t;
2889 }
2890 $avg = $avg * 0.99 + $t * 0.01;
2891 }
2892 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2893 exit 0;
2894 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2895 }; 3932 };
3933 }
2896 3934
2897 $RUNTIME += $TICK;
2898 $NEXT_TICK += $TICK;
2899
2900 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2901 $NEXT_RUNTIME_WRITE = $NOW + 10;
2902 Coro::async_pool {
2903 write_runtime
2904 or warn "ERROR: unable to write runtime file: $!";
2905 };
2906 }
2907
2908# my $AFTER = Event::time;
2909# warn $AFTER - $NOW;#d#
2910
2911 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3935 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2912 $sig->send; 3936 $sig->send;
2913 } 3937 }
2914 while (my $sig = shift @WAIT_FOR_TICK) { 3938 while (my $sig = shift @WAIT_FOR_TICK) {
2915 $sig->send; 3939 $sig->send;
2916 } 3940 }
2917 3941
2918 $NOW = Event::time; 3942 $LOAD = ($NOW - $TICK_START) / $TICK;
2919
2920 # if we are delayed by four ticks or more, skip them all
2921 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2922
2923 $TICK_WATCHER->at ($NEXT_TICK);
2924 $TICK_WATCHER->start;
2925
2926 $LOAD = ($NOW - $tick_start) / $TICK;
2927 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3943 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2928 3944
2929 _post_tick; 3945 if (0) {
2930 3946 if ($NEXT_TICK) {
2931 3947 my $jitter = $TICK_START - $NEXT_TICK;
3948 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3949 warn "jitter $JITTER\n";#d#
3950 }
2932 }, 3951 }
2933); 3952}
2934 3953
2935{ 3954{
2936 BDB::max_poll_time $TICK * 0.1; 3955 # configure BDB
2937 $BDB_POLL_WATCHER = Event->io ( 3956
2938 reentrant => 0,
2939 fd => BDB::poll_fileno,
2940 poll => 'r',
2941 prio => 0,
2942 data => WF_AUTOCANCEL,
2943 cb => \&BDB::poll_cb,
2944 );
2945 BDB::min_parallel 8; 3957 BDB::min_parallel 8;
2946 3958 BDB::max_poll_reqs $TICK * 0.1;
2947 BDB::set_sync_prepare { 3959 $AnyEvent::BDB::WATCHER->priority (1);
2948 my $status;
2949 my $current = $Coro::current;
2950 (
2951 sub {
2952 $status = $!;
2953 $current->ready; undef $current;
2954 },
2955 sub {
2956 Coro::schedule while defined $current;
2957 $! = $status;
2958 },
2959 )
2960 };
2961 3960
2962 unless ($DB_ENV) { 3961 unless ($DB_ENV) {
2963 $DB_ENV = BDB::db_env_create; 3962 $DB_ENV = BDB::db_env_create;
3963 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3964 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3965 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3966 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3967 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2964 3968
2965 cf::sync_job { 3969 cf::sync_job {
2966 eval { 3970 eval {
2967 BDB::db_env_open 3971 BDB::db_env_open
2968 $DB_ENV, 3972 $DB_ENV,
… …
2970 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3974 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2971 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3975 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2972 0666; 3976 0666;
2973 3977
2974 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3978 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2975
2976 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2977 $DB_ENV->set_lk_detect;
2978 }; 3979 };
2979 3980
2980 cf::cleanup "db_env_open(db): $@" if $@; 3981 cf::cleanup "db_env_open(db): $@" if $@;
2981 }; 3982 };
2982 } 3983 }
3984
3985 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3986 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3987 };
3988 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3989 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3990 };
3991 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3992 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3993 };
2983} 3994}
2984 3995
2985{ 3996{
3997 # configure IO::AIO
3998
2986 IO::AIO::min_parallel 8; 3999 IO::AIO::min_parallel 8;
2987
2988 undef $Coro::AIO::WATCHER;
2989 IO::AIO::max_poll_time $TICK * 0.1; 4000 IO::AIO::max_poll_time $TICK * 0.1;
2990 $AIO_POLL_WATCHER = Event->io ( 4001 undef $AnyEvent::AIO::WATCHER;
2991 reentrant => 0,
2992 data => WF_AUTOCANCEL,
2993 fd => IO::AIO::poll_fileno,
2994 poll => 'r',
2995 prio => 6,
2996 cb => \&IO::AIO::poll_cb,
2997 );
2998} 4002}
2999 4003
3000my $_log_backtrace; 4004my $_log_backtrace;
3001 4005
3002sub _log_backtrace { 4006sub _log_backtrace {
… …
3005 $msg =~ s/\n//; 4009 $msg =~ s/\n//;
3006 4010
3007 # limit the # of concurrent backtraces 4011 # limit the # of concurrent backtraces
3008 if ($_log_backtrace < 2) { 4012 if ($_log_backtrace < 2) {
3009 ++$_log_backtrace; 4013 ++$_log_backtrace;
4014 my $perl_bt = Carp::longmess $msg;
3010 async { 4015 async {
4016 $Coro::current->{desc} = "abt $msg";
4017
3011 my @bt = fork_call { 4018 my @bt = fork_call {
3012 @addr = map { sprintf "%x", $_ } @addr; 4019 @addr = map { sprintf "%x", $_ } @addr;
3013 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 4020 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3014 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 4021 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3015 or die "addr2line: $!"; 4022 or die "addr2line: $!";
… …
3023 } 4030 }
3024 4031
3025 @funcs 4032 @funcs
3026 }; 4033 };
3027 4034
3028 LOG llevInfo, "[ABT] $msg\n"; 4035 LOG llevInfo, "[ABT] $perl_bt\n";
4036 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3029 LOG llevInfo, "[ABT] $_\n" for @bt; 4037 LOG llevInfo, "[ABT] $_\n" for @bt;
3030 --$_log_backtrace; 4038 --$_log_backtrace;
3031 }; 4039 };
3032 } else { 4040 } else {
3033 LOG llevInfo, "[ABT] $msg\n"; 4041 LOG llevInfo, "[ABT] $msg\n";
3034 LOG llevInfo, "[ABT] [suppressed]\n"; 4042 LOG llevInfo, "[ABT] [suppressed]\n";
3035 } 4043 }
3036} 4044}
3037 4045
3038# load additional modules 4046# load additional modules
3039use cf::pod; 4047require "cf/$_.pm" for @EXTRA_MODULES;
4048cf::_connect_to_perl_2;
3040 4049
3041END { cf::emergency_save } 4050END { cf::emergency_save }
3042 4051
30431 40521
3044 4053

Diff Legend

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