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.276 by root, Sun Jun 10 04:05:47 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
1779} 2290}
1780 2291
1781=item $maps = cf::map::tmp_maps 2292=item $maps = cf::map::tmp_maps
1782 2293
1783Returns an arrayref with all map paths of currently instantiated and saved 2294Returns an arrayref with all map paths of currently instantiated and saved
1784maps. 2295maps. May block.
1785 2296
1786=cut 2297=cut
1787 2298
1788sub tmp_maps() { 2299sub tmp_maps() {
1789 [ 2300 [
1790 map { 2301 map {
1791 utf8::decode $_; 2302 utf8::decode $_;
1792 !/\.(?:pst|meta)$/ && /^$PATH_SEP/o 2303 /\.map$/
1793 ? normalise $_ 2304 ? normalise $_
1794 : () 2305 : ()
1795 } @{ aio_readdir $TMPDIR or [] } 2306 } @{ aio_readdir $TMPDIR or [] }
1796 ] 2307 ]
1797} 2308}
1798 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 ]
2326}
2327
1799=item cf::map::unique_maps 2328=item cf::map::unique_maps
1800 2329
1801Returns an arrayref of paths of all shared maps that have 2330Returns an arrayref of paths of all shared maps that have
1802instantiated unique items. May block. 2331instantiated unique items. May block.
1803 2332
… …
1805 2334
1806sub unique_maps() { 2335sub unique_maps() {
1807 [ 2336 [
1808 map { 2337 map {
1809 utf8::decode $_; 2338 utf8::decode $_;
1810 !/\.(?:pst|meta)$/ && /^$PATH_SEP/o 2339 s/\.map$//; # TODO future compatibility hack
2340 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2341 ? ()
1811 ? normalise $_ 2342 : normalise $_
1812 : ()
1813 } @{ aio_readdir $UNIQUEDIR or [] } 2343 } @{ aio_readdir $UNIQUEDIR or [] }
1814 ] 2344 ]
1815} 2345}
1816 2346
1817package 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}
1818 2378
1819=back 2379=back
1820 2380
1821=head3 cf::object 2381=head3 cf::object
1822 2382
… …
1826 2386
1827=over 4 2387=over 4
1828 2388
1829=item $ob->inv_recursive 2389=item $ob->inv_recursive
1830 2390
1831Returns 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.
1832 2393
1833=cut 2394=cut
1834 2395
1835sub inv_recursive_; 2396sub inv_recursive_;
1836sub inv_recursive_ { 2397sub inv_recursive_ {
… …
1839 2400
1840sub inv_recursive { 2401sub inv_recursive {
1841 inv_recursive_ inv $_[0] 2402 inv_recursive_ inv $_[0]
1842} 2403}
1843 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
1844package cf; 2433package cf;
1845 2434
1846=back 2435=back
1847 2436
1848=head3 cf::object::player 2437=head3 cf::object::player
… …
1854Sends 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>
1855can 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
1856dialogue with the given NPC character. 2445dialogue with the given NPC character.
1857 2446
1858=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};
1859 2462
1860# rough implementation of a future "reply" method that works 2463# rough implementation of a future "reply" method that works
1861# with dialog boxes. 2464# with dialog boxes.
1862#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
1863sub cf::object::player::reply($$$;$) { 2466sub cf::object::player::reply($$$;$) {
… …
1865 2468
1866 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2469 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1867 2470
1868 if ($self->{record_replies}) { 2471 if ($self->{record_replies}) {
1869 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2472 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2473
1870 } 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 {
1871 $msg = $npc->name . " says: $msg" if $npc; 2482 $msg = $npc->name . " says: $msg" if $npc;
1872 $self->message ($msg, $flags); 2483 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2484 }
1873 } 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 (@_);
1874} 2496}
1875 2497
1876=item $player_object->may ("access") 2498=item $player_object->may ("access")
1877 2499
1878Returns wether the given player is authorized to access resource "access" 2500Returns wether the given player is authorized to access resource "access"
… …
1891 2513
1892=item $player_object->enter_link 2514=item $player_object->enter_link
1893 2515
1894Freezes 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}>).
1895 2517
1896The 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.
1897I<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.
1898 2522
1899Will never block. 2523Will never block.
1900 2524
1901=item $player_object->leave_link ($map, $x, $y) 2525=item $player_object->leave_link ($map, $x, $y)
1902 2526
… …
1954 ($x, $y) = (-1, -1) 2578 ($x, $y) = (-1, -1)
1955 unless (defined $x) && (defined $y); 2579 unless (defined $x) && (defined $y);
1956 2580
1957 # use -1 or undef as default coordinates, not 0, 0 2581 # use -1 or undef as default coordinates, not 0, 0
1958 ($x, $y) = ($map->enter_x, $map->enter_y) 2582 ($x, $y) = ($map->enter_x, $map->enter_y)
1959 if $x <=0 && $y <= 0; 2583 if $x <= 0 && $y <= 0;
1960 2584
1961 $map->load; 2585 $map->load;
1962 $map->load_diag; 2586 $map->load_neighbours;
1963 2587
1964 return unless $self->contr->active; 2588 return unless $self->contr->active;
1965 $self->activate_recursive;
1966 2589
1967 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2590 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1968 $self->enter_map ($map, $x, $y); 2591 $self->enter_map ($map, $x, $y);
1969}
1970 2592
2593 # only activate afterwards, to support waiting in hooks
2594 $self->activate_recursive;
2595}
2596
1971=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2597=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1972 2598
1973Moves 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
1974her, loading and preparing them map, calling the provided $check callback 2600her, loading and preparing them map, calling the provided $check callback
1975that 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
1976the 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 >>.
1977 2607
1978=cut 2608=cut
1979 2609
1980our $GOTOGEN; 2610our $GOTOGEN;
1981 2611
1982sub cf::object::player::goto { 2612sub cf::object::player::goto {
1983 my ($self, $path, $x, $y, $check) = @_; 2613 my ($self, $path, $x, $y, $check, $done) = @_;
1984 2614
1985 # 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
1986 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2616 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1987 2617
1988 $self->enter_link; 2618 $self->enter_link;
1989 2619
1990 (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
1991 my $map = eval { 2642 my $map = eval {
1992 my $map = cf::map::find $path; 2643 my $map = defined $path ? cf::map::find $path : undef;
1993 2644
1994 if ($map) { 2645 if ($map) {
1995 $map = $map->customise_for ($self); 2646 $map = $map->customise_for ($self);
1996 $map = $check->($map) if $check && $map; 2647 $map = $check->($map) if $check && $map;
1997 } else { 2648 } else {
1998 $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);
1999 } 2650 }
2000 2651
2001 $map 2652 $map
2002 }; 2653 };
2003 2654
… …
2008 2659
2009 if ($gen == $self->{_goto_generation}) { 2660 if ($gen == $self->{_goto_generation}) {
2010 delete $self->{_goto_generation}; 2661 delete $self->{_goto_generation};
2011 $self->leave_link ($map, $x, $y); 2662 $self->leave_link ($map, $x, $y);
2012 } 2663 }
2664
2665 $done->() if $done;
2013 })->prio (1); 2666 })->prio (1);
2014} 2667}
2015 2668
2016=item $player_object->enter_exit ($exit_object) 2669=item $player_object->enter_exit ($exit_object)
2017 2670
… …
2037} 2690}
2038 2691
2039sub prepare_random_map { 2692sub prepare_random_map {
2040 my ($exit) = @_; 2693 my ($exit) = @_;
2041 2694
2042 my $guard = cf::lock_acquire "exit_prepare:$exit";
2043
2044 # all this does is basically replace the /! path by 2695 # all this does is basically replace the /! path by
2045 # a new random map path (?random/...) with a seed 2696 # a new random map path (?random/...) with a seed
2046 # that depends on the exit object 2697 # that depends on the exit object
2047 2698
2048 my $rmp = parse_random_map_params $exit->msg; 2699 my $rmp = parse_random_map_params $exit->msg;
… …
2050 if ($exit->map) { 2701 if ($exit->map) {
2051 $rmp->{region} = $exit->region->name; 2702 $rmp->{region} = $exit->region->name;
2052 $rmp->{origin_map} = $exit->map->path; 2703 $rmp->{origin_map} = $exit->map->path;
2053 $rmp->{origin_x} = $exit->x; 2704 $rmp->{origin_x} = $exit->x;
2054 $rmp->{origin_y} = $exit->y; 2705 $rmp->{origin_y} = $exit->y;
2706
2707 $exit->map->touch;
2055 } 2708 }
2056 2709
2057 $rmp->{random_seed} ||= $exit->random_seed; 2710 $rmp->{random_seed} ||= $exit->random_seed;
2058 2711
2059 my $data = cf::to_json $rmp; 2712 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2060 my $md5 = Digest::MD5::md5_hex $data; 2713 my $md5 = Digest::MD5::md5_hex $data;
2061 my $meta = "$RANDOMDIR/$md5.meta"; 2714 my $meta = "$RANDOMDIR/$md5.meta";
2062 2715
2063 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2716 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2064 aio_write $fh, 0, (length $data), $data, 0; 2717 aio_write $fh, 0, (length $data), $data, 0;
2065 undef $fh; 2718 undef $fh;
2066 aio_rename "$meta~", $meta; 2719 aio_rename "$meta~", $meta;
2067 2720
2721 my $slaying = "?random/$md5";
2722
2723 if ($exit->valid) {
2068 $exit->slaying ("?random/$md5"); 2724 $exit->slaying ("?random/$md5");
2069 $exit->msg (undef); 2725 $exit->msg (undef);
2726 }
2070 } 2727 }
2071} 2728}
2072 2729
2073sub cf::object::player::enter_exit { 2730sub cf::object::player::enter_exit {
2074 my ($self, $exit) = @_; 2731 my ($self, $exit) = @_;
2075 2732
2076 return unless $self->type == cf::PLAYER; 2733 return unless $self->type == cf::PLAYER;
2077 2734
2078 if ($exit->slaying eq "/!") {
2079 #TODO: this should de-fi-ni-te-ly not be a sync-job
2080 # the problem is that $exit might not survive long enough
2081 # so it needs to be done right now, right here
2082 cf::sync_job { prepare_random_map $exit };
2083 }
2084
2085 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2086 my $hp = $exit->stats->hp;
2087 my $sp = $exit->stats->sp;
2088
2089 $self->enter_link; 2735 $self->enter_link;
2090 2736
2091 (async { 2737 (async {
2092 $self->deactivate_recursive; # just to be sure 2738 $Coro::current->{desc} = "enter_exit";
2739
2093 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
2094 $self->goto ($slaying, $hp, $sp); 2755 $self->goto ($map, $x, $y);
2095 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
2096 1; 2761 1
2097 }) { 2762 }) {
2098 $self->message ("Something went wrong deep within the crossfire server. " 2763 $self->message ("Something went wrong deep within the deliantra server. "
2099 . "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. "
2100 . "Please report this to the dungeon master!", 2765 . "Please report this to the dungeon master!",
2101 cf::NDI_UNIQUE | cf::NDI_RED); 2766 cf::NDI_UNIQUE | cf::NDI_RED);
2102 2767
2103 warn "ERROR in enter_exit: $@"; 2768 warn "ERROR in enter_exit: $@";
… …
2122 2787
2123 utf8::encode $text; 2788 utf8::encode $text;
2124 $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);
2125} 2790}
2126 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
2127=item $client->ext_event ($type, %msg) 2979=item $client->ext_msg ($type, @msg)
2128 2980
2129Sends an exti event to the client. 2981Sends an ext event to the client.
2130 2982
2131=cut 2983=cut
2132 2984
2133sub cf::client::ext_event($$%) { 2985sub cf::client::ext_msg($$@) {
2134 my ($self, $type, %msg) = @_; 2986 my ($self, $type, @msg) = @_;
2135 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
2136 $msg{msgtype} = "event_$type"; 2991 push @msg, msgtype => "event_$type";
2137 $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 }
2138} 3012}
2139 3013
2140=item $success = $client->query ($flags, "text", \&cb) 3014=item $success = $client->query ($flags, "text", \&cb)
2141 3015
2142Queues a query to the client, calling the given callback with 3016Queues a query to the client, calling the given callback with
2143the 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>,
2144C<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>.
2145 3019
2146Queries 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
2147reliable at some point in the future. 3021become reliable at some point in the future.
2148 3022
2149=cut 3023=cut
2150 3024
2151sub cf::client::query { 3025sub cf::client::query {
2152 my ($self, $flags, $text, $cb) = @_; 3026 my ($self, $flags, $text, $cb) = @_;
… …
2160 utf8::encode $text; 3034 utf8::encode $text;
2161 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3035 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2162 3036
2163 $self->send_packet ($self->{query_queue}[0][0]) 3037 $self->send_packet ($self->{query_queue}[0][0])
2164 if @{ $self->{query_queue} } == 1; 3038 if @{ $self->{query_queue} } == 1;
3039
3040 1
2165} 3041}
2166 3042
2167cf::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 },
2168 on_reply => sub { 3049 on_reply => sub {
2169 my ($ns, $msg) = @_; 3050 my ($ns, $msg) = @_;
2170 3051
2171 # this weird shuffling is so that direct followup queries 3052 # this weird shuffling is so that direct followup queries
2172 # get handled first 3053 # get handled first
… …
2184 } else { 3065 } else {
2185 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3066 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2186 } 3067 }
2187 } 3068 }
2188 }, 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 },
2189); 3096);
2190 3097
2191=item $client->async (\&cb) 3098=item $client->async (\&cb)
2192 3099
2193Create a new coroutine, running the specified callback. The coroutine will 3100Create a new coroutine, running the specified callback. The coroutine will
… …
2234our $safe = new Safe "safe"; 3141our $safe = new Safe "safe";
2235our $safe_hole = new Safe::Hole; 3142our $safe_hole = new Safe::Hole;
2236 3143
2237$SIG{FPE} = 'IGNORE'; 3144$SIG{FPE} = 'IGNORE';
2238 3145
2239$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));
2240 3151
2241# here we export the classes and methods available to script code 3152# here we export the classes and methods available to script code
2242 3153
2243=pod 3154=pod
2244 3155
2245The following functions and methods are available within a safe environment: 3156The following functions and methods are available within a safe environment:
2246 3157
2247 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
2248 cf::object::player player 3163 cf::object::player
2249 cf::player peaceful 3164 player
2250 cf::map trigger 3165
3166 cf::player
3167 peaceful
3168
3169 cf::map
3170 trigger
2251 3171
2252=cut 3172=cut
2253 3173
2254for ( 3174for (
2255 ["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)],
2256 ["cf::object::player" => qw(player)], 3178 ["cf::object::player" => qw(player)],
2257 ["cf::player" => qw(peaceful)], 3179 ["cf::player" => qw(peaceful send_msg)],
2258 ["cf::map" => qw(trigger)], 3180 ["cf::map" => qw(trigger)],
2259) { 3181) {
2260 no strict 'refs'; 3182 no strict 'refs';
2261 my ($pkg, @funs) = @$_; 3183 my ($pkg, @funs) = @$_;
2262 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3184 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
2279 my ($code, %vars) = @_; 3201 my ($code, %vars) = @_;
2280 3202
2281 my $qcode = $code; 3203 my $qcode = $code;
2282 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3204 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2283 $qcode =~ s/\n/\\n/g; 3205 $qcode =~ s/\n/\\n/g;
3206
3207 %vars = (_dummy => 0) unless %vars;
2284 3208
2285 local $_; 3209 local $_;
2286 local @safe::cf::_safe_eval_args = values %vars; 3210 local @safe::cf::_safe_eval_args = values %vars;
2287 3211
2288 my $eval = 3212 my $eval =
… …
2331=back 3255=back
2332 3256
2333=cut 3257=cut
2334 3258
2335############################################################################# 3259#############################################################################
2336
2337=head2 EXTENSION DATABASE SUPPORT
2338
2339Crossfire maintains a very simple database for extension use. It can
2340currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2341convert to/from binary).
2342
2343The parameter C<$family> should best start with the name of the extension
2344using it, it should be unique.
2345
2346=over 4
2347
2348=item $value = cf::db_get $family => $key
2349
2350Returns a single value from the database.
2351
2352=item cf::db_put $family => $key => $value
2353
2354Stores the given C<$value> in the family.
2355
2356=cut
2357
2358our $DB;
2359
2360sub db_init {
2361 unless ($DB) {
2362 $DB = BDB::db_create $DB_ENV;
2363
2364 cf::sync_job {
2365 eval {
2366 $DB->set_flags (BDB::CHKSUM);
2367
2368 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2369 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2370 cf::cleanup "db_open(db): $!" if $!;
2371 };
2372 cf::cleanup "db_open(db): $@" if $@;
2373 };
2374 }
2375}
2376
2377sub db_get($$) {
2378 my $key = "$_[0]/$_[1]";
2379
2380 cf::sync_job {
2381 BDB::db_get $DB, undef, $key, my $data;
2382
2383 $! ? ()
2384 : $data
2385 }
2386}
2387
2388sub db_put($$$) {
2389 BDB::dbreq_pri 4;
2390 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2391}
2392
2393=item cf::cache $id => [$paths...], $processversion => $process
2394
2395Generic caching function that returns the value of the resource $id,
2396caching and regenerating as required.
2397
2398This function can block.
2399
2400=cut
2401
2402sub cache {
2403 my ($id, $src, $processversion, $process) = @_;
2404
2405 my $meta =
2406 join "\x00",
2407 $processversion,
2408 map {
2409 aio_stat $_
2410 and Carp::croak "$_: $!";
2411
2412 ($_, (stat _)[7,9])
2413 } @$src;
2414
2415 my $dbmeta = db_get cache => "$id/meta";
2416 if ($dbmeta ne $meta) {
2417 # changed, we may need to process
2418
2419 my @data;
2420 my $md5;
2421
2422 for (0 .. $#$src) {
2423 0 <= aio_load $src->[$_], $data[$_]
2424 or Carp::croak "$src->[$_]: $!";
2425 }
2426
2427 # if processing is expensive, check
2428 # checksum first
2429 if (1) {
2430 $md5 =
2431 join "\x00",
2432 $processversion,
2433 map {
2434 Coro::cede;
2435 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2436 } 0.. $#$src;
2437
2438
2439 my $dbmd5 = db_get cache => "$id/md5";
2440 if ($dbmd5 eq $md5) {
2441 db_put cache => "$id/meta", $meta;
2442
2443 return db_get cache => "$id/data";
2444 }
2445 }
2446
2447 my $t1 = Time::HiRes::time;
2448 my $data = $process->(\@data);
2449 my $t2 = Time::HiRes::time;
2450
2451 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2452
2453 db_put cache => "$id/data", $data;
2454 db_put cache => "$id/md5" , $md5;
2455 db_put cache => "$id/meta", $meta;
2456
2457 return $data;
2458 }
2459
2460 db_get cache => "$id/data"
2461}
2462
2463=item fork_call { }, $args
2464
2465Executes the given code block with the given arguments in a seperate
2466process, returning the results. Everything must be serialisable with
2467Coro::Storable. May, of course, block. Note that the executed sub may
2468never block itself or use any form of Event handling.
2469
2470=cut
2471
2472sub fork_call(&@) {
2473 my ($cb, @args) = @_;
2474
2475# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2476# or die "socketpair: $!";
2477 pipe my $fh1, my $fh2
2478 or die "pipe: $!";
2479
2480 if (my $pid = fork) {
2481 close $fh2;
2482
2483 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2484 $res = Coro::Storable::thaw $res;
2485
2486 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2487
2488 die $$res unless "ARRAY" eq ref $res;
2489
2490 return wantarray ? @$res : $res->[-1];
2491 } else {
2492 reset_signals;
2493 local $SIG{__WARN__};
2494 local $SIG{__DIE__};
2495 eval {
2496 close $fh1;
2497
2498 my @res = eval { $cb->(@args) };
2499 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2500 };
2501
2502 warn $@ if $@;
2503 _exit 0;
2504 }
2505}
2506
2507#############################################################################
2508# the server's init and main functions 3260# the server's init and main functions
2509 3261
2510sub load_facedata($) { 3262sub load_facedata($) {
2511 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;
2512 3270
2513 warn "loading facedata from $path\n"; 3271 warn "loading facedata from $path\n";
2514 3272
2515 my $facedata; 3273 my $facedata;
2516 0 < aio_load $path, $facedata 3274 0 < aio_load $path, $facedata
… …
2519 $facedata = Coro::Storable::thaw $facedata; 3277 $facedata = Coro::Storable::thaw $facedata;
2520 3278
2521 $facedata->{version} == 2 3279 $facedata->{version} == 2
2522 or cf::cleanup "$path: version mismatch, cannot proceed."; 3280 or cf::cleanup "$path: version mismatch, cannot proceed.";
2523 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
2524 { 3289 {
2525 my $faces = $facedata->{faceinfo}; 3290 my $faces = $facedata->{faceinfo};
2526 3291
2527 while (my ($face, $info) = each %$faces) { 3292 while (my ($face, $info) = each %$faces) {
2528 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3293 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3294
2529 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3295 cf::face::set_visibility $idx, $info->{visibility};
3296 cf::face::set_magicmap $idx, $info->{magicmap};
2530 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3297 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2531 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3298 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2532 Coro::cede; 3299
3300 cf::cede_to_tick;
2533 } 3301 }
2534 3302
2535 while (my ($face, $info) = each %$faces) { 3303 while (my ($face, $info) = each %$faces) {
2536 next unless $info->{smooth}; 3304 next unless $info->{smooth};
3305
2537 my $idx = cf::face::find $face 3306 my $idx = cf::face::find $face
2538 or next; 3307 or next;
3308
2539 if (my $smooth = cf::face::find $info->{smooth}) { 3309 if (my $smooth = cf::face::find $info->{smooth}) {
3310 cf::face::set_smooth $idx, $smooth;
2540 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3311 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2541 } else { 3312 } else {
2542 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3313 warn "smooth face '$info->{smooth}' not found for face '$face'";
2543 } 3314 }
2544 Coro::cede; 3315
3316 cf::cede_to_tick;
2545 } 3317 }
2546 } 3318 }
2547 3319
2548 { 3320 {
2549 my $anims = $facedata->{animinfo}; 3321 my $anims = $facedata->{animinfo};
2550 3322
2551 while (my ($anim, $info) = each %$anims) { 3323 while (my ($anim, $info) = each %$anims) {
2552 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3324 cf::anim::set $anim, $info->{frames}, $info->{facings};
2553 Coro::cede; 3325 cf::cede_to_tick;
2554 } 3326 }
2555 3327
2556 cf::anim::invalidate_all; # d'oh 3328 cf::anim::invalidate_all; # d'oh
2557 } 3329 }
2558 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
2559 1 3366 1
2560} 3367}
2561 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
2562sub 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
2563 load_resource_file "$MAPDIR/regions" 3412 load_resource_file "$MAPDIR/regions"
2564 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 }
2565} 3419}
2566 3420
2567sub reload_facedata { 3421sub reload_facedata {
2568 load_facedata "$DATADIR/facedata" 3422 load_facedata "$DATADIR/facedata"
2569 or die "unable to load facedata\n"; 3423 or die "unable to load facedata\n";
… …
2580} 3434}
2581 3435
2582sub reload_resources { 3436sub reload_resources {
2583 warn "reloading resource files...\n"; 3437 warn "reloading resource files...\n";
2584 3438
3439 reload_facedata;
3440 reload_archetypes;
2585 reload_regions; 3441 reload_regions;
2586 reload_facedata;
2587 #reload_archetypes;#d#
2588 reload_archetypes;
2589 reload_treasures; 3442 reload_treasures;
2590 3443
2591 warn "finished reloading resource files\n"; 3444 warn "finished reloading resource files\n";
2592} 3445}
2593 3446
2594sub init { 3447sub reload_config {
2595 reload_resources; 3448 warn "reloading config file...\n";
2596}
2597 3449
2598sub cfg_load {
2599 open my $fh, "<:utf8", "$CONFDIR/config" 3450 open my $fh, "<:utf8", "$CONFDIR/config"
2600 or return; 3451 or return;
2601 3452
2602 local $/; 3453 local $/;
2603 *CFG = YAML::Syck::Load <$fh>; 3454 *CFG = YAML::XS::Load scalar <$fh>;
2604 3455
2605 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3456 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2606 3457
2607 $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};
2608 $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};
… …
2612 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3463 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2613 and die "WARNING: m(un)lockall failed: $!\n"; 3464 and die "WARNING: m(un)lockall failed: $!\n";
2614 }; 3465 };
2615 warn $@ if $@; 3466 warn $@ if $@;
2616 } 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;
2617} 3498}
2618 3499
2619sub 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
2620 # we must not ever block the main coroutine 3515 # we must not ever block the main coroutine
2621 local $Coro::idle = sub { 3516 local $Coro::idle = sub {
2622 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#
2623 (async { 3518 (async {
2624 Event::one_event; 3519 $Coro::current->{desc} = "IDLE BUG HANDLER";
3520 EV::loop EV::LOOP_ONESHOT;
2625 })->prio (Coro::PRIO_MAX); 3521 })->prio (Coro::PRIO_MAX);
2626 }; 3522 };
2627 3523
2628 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;
2629 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
2630 load_extensions; 3543 load_extensions;
2631 3544
2632 $TICK_WATCHER->start; 3545 utime time, time, $RUNTIMEFILE;
2633 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;
2634} 3555}
2635 3556
2636############################################################################# 3557#############################################################################
2637# initialisation and cleanup 3558# initialisation and cleanup
2638 3559
2639# install some emergency cleanup handlers 3560# install some emergency cleanup handlers
2640BEGIN { 3561BEGIN {
3562 our %SIGWATCHER = ();
2641 for my $signal (qw(INT HUP TERM)) { 3563 for my $signal (qw(INT HUP TERM)) {
2642 Event->signal ( 3564 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2643 reentrant => 0,
2644 data => WF_AUTOCANCEL,
2645 signal => $signal,
2646 prio => 0,
2647 cb => sub {
2648 cf::cleanup "SIG$signal"; 3565 cf::cleanup "SIG$signal";
2649 },
2650 ); 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
2651 } 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 };
2652} 3654}
2653 3655
2654sub emergency_save() { 3656sub emergency_save() {
2655 my $freeze_guard = cf::freeze_mainloop; 3657 my $freeze_guard = cf::freeze_mainloop;
2656 3658
2657 warn "enter emergency perl save\n"; 3659 warn "emergency_perl_save: enter\n";
2658 3660
2659 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
2660 # use a peculiar iteration method to avoid tripping on perl 3667 # use a peculiar iteration method to avoid tripping on perl
2661 # refcount bugs in for. also avoids problems with players 3668 # refcount bugs in for. also avoids problems with players
2662 # and maps saved/destroyed asynchronously. 3669 # and maps saved/destroyed asynchronously.
2663 warn "begin emergency player save\n"; 3670 warn "emergency_perl_save: begin player save\n";
2664 for my $login (keys %cf::PLAYER) { 3671 for my $login (keys %cf::PLAYER) {
2665 my $pl = $cf::PLAYER{$login} or next; 3672 my $pl = $cf::PLAYER{$login} or next;
2666 $pl->valid or next; 3673 $pl->valid or next;
3674 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2667 $pl->save; 3675 $pl->save;
2668 } 3676 }
2669 warn "end emergency player save\n"; 3677 warn "emergency_perl_save: end player save\n";
2670 3678
2671 warn "begin emergency map save\n"; 3679 warn "emergency_perl_save: begin map save\n";
2672 for my $path (keys %cf::MAP) { 3680 for my $path (keys %cf::MAP) {
2673 my $map = $cf::MAP{$path} or next; 3681 my $map = $cf::MAP{$path} or next;
2674 $map->valid or next; 3682 $map->valid or next;
2675 $map->save; 3683 $map->save;
2676 } 3684 }
2677 warn "end emergency map save\n"; 3685 warn "emergency_perl_save: end map save\n";
2678 3686
2679 warn "begin emergency database checkpoint\n"; 3687 warn "emergency_perl_save: begin database checkpoint\n";
2680 BDB::db_env_txn_checkpoint $DB_ENV; 3688 BDB::db_env_txn_checkpoint $DB_ENV;
2681 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";
2682 }; 3694 };
2683 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
2684 warn "leave emergency perl save\n"; 3701 warn "emergency_perl_save: leave\n";
2685} 3702}
2686 3703
2687sub post_cleanup { 3704sub post_cleanup {
2688 my ($make_core) = @_; 3705 my ($make_core) = @_;
2689 3706
2690 warn Carp::longmess "post_cleanup backtrace" 3707 warn Carp::longmess "post_cleanup backtrace"
2691 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#
2692} 3738}
2693 3739
2694sub do_reload_perl() { 3740sub do_reload_perl() {
2695 # can/must only be called in main 3741 # can/must only be called in main
2696 if ($Coro::current != $Coro::main) { 3742 if ($Coro::current != $Coro::main) {
2697 warn "can only reload from main coroutine"; 3743 warn "can only reload from main coroutine";
2698 return; 3744 return;
2699 } 3745 }
2700 3746
3747 return if $RELOAD++;
3748
3749 my $t1 = EV::time;
3750
3751 while ($RELOAD) {
2701 warn "reloading..."; 3752 warn "reloading...";
2702 3753
2703 warn "entering sync_job"; 3754 warn "entering sync_job";
2704 3755
2705 cf::sync_job { 3756 cf::sync_job {
2706 cf::write_runtime; # external watchdog should not bark 3757 cf::write_runtime_sync; # external watchdog should not bark
2707 cf::emergency_save; 3758 cf::emergency_save;
2708 cf::write_runtime; # external watchdog should not bark 3759 cf::write_runtime_sync; # external watchdog should not bark
2709 3760
2710 warn "syncing database to disk"; 3761 warn "syncing database to disk";
2711 BDB::db_env_txn_checkpoint $DB_ENV; 3762 BDB::db_env_txn_checkpoint $DB_ENV;
2712 3763
2713 # 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
2714 3765
2715 warn "cancelling all WF_AUTOCANCEL watchers";
2716 for (Event::all_watchers) {
2717 $_->cancel if $_->data & WF_AUTOCANCEL;
2718 }
2719
2720 warn "flushing outstanding aio requests"; 3766 warn "flushing outstanding aio requests";
2721 for (;;) {
2722 BDB::flush;
2723 IO::AIO::flush;
2724 Coro::cede;
2725 last unless IO::AIO::nreqs || BDB::nreqs; 3767 while (IO::AIO::nreqs || BDB::nreqs) {
2726 warn "iterate..."; 3768 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2727 }
2728
2729 ++$RELOAD;
2730
2731 warn "cancelling all extension coros";
2732 $_->cancel for values %EXT_CORO;
2733 %EXT_CORO = ();
2734
2735 warn "removing commands";
2736 %COMMAND = ();
2737
2738 warn "removing ext commands";
2739 %EXTCMD = ();
2740
2741 warn "unloading/nuking all extensions";
2742 for my $pkg (@EXTS) {
2743 warn "... unloading $pkg";
2744
2745 if (my $cb = $pkg->can ("unload")) {
2746 eval {
2747 $cb->($pkg);
2748 1
2749 } or warn "$pkg unloaded, but with errors: $@";
2750 } 3769 }
2751 3770
2752 warn "... nuking $pkg"; 3771 warn "cancelling all extension coros";
2753 Symbol::delete_package $pkg; 3772 $_->cancel for values %EXT_CORO;
2754 } 3773 %EXT_CORO = ();
2755 3774
2756 warn "unloading all perl modules loaded from $LIBDIR"; 3775 warn "removing commands";
2757 while (my ($k, $v) = each %INC) { 3776 %COMMAND = ();
2758 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2759 3777
3778 warn "removing ext/exti commands";
3779 %EXTCMD = ();
3780 %EXTICMD = ();
3781
3782 warn "unloading/nuking all extensions";
3783 for my $pkg (@EXTS) {
2760 warn "... unloading $k"; 3784 warn "... unloading $pkg";
2761 delete $INC{$k};
2762 3785
2763 $k =~ s/\.pm$//;
2764 $k =~ s/\//::/g;
2765
2766 if (my $cb = $k->can ("unload_module")) { 3786 if (my $cb = $pkg->can ("unload")) {
3787 eval {
2767 $cb->(); 3788 $cb->($pkg);
3789 1
3790 } or warn "$pkg unloaded, but with errors: $@";
3791 }
3792
3793 warn "... clearing $pkg";
3794 clear_package $pkg;
2768 } 3795 }
2769 3796
2770 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;
2771 } 3812 }
2772 3813
2773 warn "getting rid of safe::, as good as possible"; 3814 warn "getting rid of safe::, as good as possible";
2774 Symbol::delete_package "safe::$_" 3815 clear_package "safe::$_"
2775 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);
2776 3817
2777 warn "unloading cf.pm \"a bit\""; 3818 warn "unloading cf.pm \"a bit\"";
2778 delete $INC{"cf.pm"}; 3819 delete $INC{"cf.pm"};
2779 delete $INC{"cf/pod.pm"}; 3820 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2780 3821
2781 # don't, removes xs symbols, too, 3822 # don't, removes xs symbols, too,
2782 # and global variables created in xs 3823 # and global variables created in xs
2783 #Symbol::delete_package __PACKAGE__; 3824 #clear_package __PACKAGE__;
2784 3825
2785 warn "unload completed, starting to reload now"; 3826 warn "unload completed, starting to reload now";
2786 3827
2787 warn "reloading cf.pm"; 3828 warn "reloading cf.pm";
2788 require cf; 3829 require cf;
2789 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3830 cf::_connect_to_perl_1;
2790 3831
2791 warn "loading config and database again"; 3832 warn "loading config and database again";
2792 cf::cfg_load; 3833 cf::reload_config;
2793 3834
2794 warn "loading extensions"; 3835 warn "loading extensions";
2795 cf::load_extensions; 3836 cf::load_extensions;
2796 3837
3838 if ($REATTACH_ON_RELOAD) {
2797 warn "reattaching attachments to objects/players"; 3839 warn "reattaching attachments to objects/players";
2798 _global_reattach; # objects, sockets 3840 _global_reattach; # objects, sockets
2799 warn "reattaching attachments to maps"; 3841 warn "reattaching attachments to maps";
2800 reattach $_ for values %MAP; 3842 reattach $_ for values %MAP;
2801 warn "reattaching attachments to players"; 3843 warn "reattaching attachments to players";
2802 reattach $_ for values %PLAYER; 3844 reattach $_ for values %PLAYER;
3845 }
2803 3846
3847 warn "running post_init jobs";
3848 (pop @POST_INIT)->(1) while @POST_INIT;
3849
2804 warn "leaving sync_job"; 3850 warn "leaving sync_job";
2805 3851
2806 1 3852 1
2807 } or do { 3853 } or do {
2808 warn $@; 3854 warn $@;
2809 warn "error while reloading, exiting."; 3855 cf::cleanup "error while reloading, exiting.";
2810 exit 1;
2811 }; 3856 };
2812 3857
2813 warn "reloaded"; 3858 warn "reloaded";
3859 --$RELOAD;
3860 }
3861
3862 $t1 = EV::time - $t1;
3863 warn "reload completed in ${t1}s\n";
2814}; 3864};
2815 3865
2816our $RELOAD_WATCHER; # used only during reload 3866our $RELOAD_WATCHER; # used only during reload
2817 3867
2818sub reload_perl() { 3868sub reload_perl() {
2819 # doing reload synchronously and two reloads happen back-to-back, 3869 # doing reload synchronously and two reloads happen back-to-back,
2820 # coro crashes during coro_state_free->destroy here. 3870 # coro crashes during coro_state_free->destroy here.
2821 3871
2822 $RELOAD_WATCHER ||= Event->timer ( 3872 $RELOAD_WATCHER ||= cf::async {
2823 reentrant => 0, 3873 Coro::AIO::aio_wait cache_extensions;
2824 after => 0, 3874
2825 data => WF_AUTOCANCEL, 3875 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
2826 cb => sub {
2827 do_reload_perl; 3876 do_reload_perl;
2828 undef $RELOAD_WATCHER; 3877 undef $RELOAD_WATCHER;
2829 }, 3878 };
2830 ); 3879 };
2831} 3880}
2832 3881
2833register_command "reload" => sub { 3882register_command "reload" => sub {
2834 my ($who, $arg) = @_; 3883 my ($who, $arg) = @_;
2835 3884
2836 if ($who->flag (FLAG_WIZ)) { 3885 if ($who->flag (FLAG_WIZ)) {
2837 $who->message ("reloading server."); 3886 $who->message ("reloading server.");
3887 async {
3888 $Coro::current->{desc} = "perl_reload";
2838 async { reload_perl }; 3889 reload_perl;
3890 };
2839 } 3891 }
2840}; 3892};
2841 3893
2842unshift @INC, $LIBDIR; 3894unshift @INC, $LIBDIR;
2843 3895
… …
2845 3897
2846our @WAIT_FOR_TICK; 3898our @WAIT_FOR_TICK;
2847our @WAIT_FOR_TICK_BEGIN; 3899our @WAIT_FOR_TICK_BEGIN;
2848 3900
2849sub wait_for_tick { 3901sub wait_for_tick {
2850 return unless $TICK_WATCHER->is_active;
2851 return if $Coro::current == $Coro::main; 3902 return if tick_inhibit || $Coro::current == $Coro::main;
2852 3903
2853 my $signal = new Coro::Signal; 3904 my $signal = new Coro::Signal;
2854 push @WAIT_FOR_TICK, $signal; 3905 push @WAIT_FOR_TICK, $signal;
2855 $signal->wait; 3906 $signal->wait;
2856} 3907}
2857 3908
2858sub wait_for_tick_begin { 3909sub wait_for_tick_begin {
2859 return unless $TICK_WATCHER->is_active;
2860 return if $Coro::current == $Coro::main; 3910 return if tick_inhibit || $Coro::current == $Coro::main;
2861 3911
2862 my $signal = new Coro::Signal; 3912 my $signal = new Coro::Signal;
2863 push @WAIT_FOR_TICK_BEGIN, $signal; 3913 push @WAIT_FOR_TICK_BEGIN, $signal;
2864 $signal->wait; 3914 $signal->wait;
2865} 3915}
2866 3916
2867 my $min = 1e6;#d# 3917sub tick {
2868 my $avg = 10;
2869$TICK_WATCHER = Event->timer (
2870 reentrant => 0,
2871 parked => 1,
2872 prio => 0,
2873 at => $NEXT_TICK || $TICK,
2874 data => WF_AUTOCANCEL,
2875 cb => sub {
2876 if ($Coro::current != $Coro::main) { 3918 if ($Coro::current != $Coro::main) {
2877 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"
2878 unless ++$bug_warning > 10; 3920 unless ++$bug_warning > 10;
2879 return; 3921 return;
2880 } 3922 }
2881 3923
2882 $NOW = $tick_start = Event::time;
2883
2884 cf::server_tick; # one server iteration 3924 cf::server_tick; # one server iteration
2885 3925
2886 0 && sync_job {#d# 3926 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2887 for(1..10) { 3927 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2888 my $t = Event::time; 3928 Coro::async_pool {
2889 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3929 $Coro::current->{desc} = "runtime saver";
2890 or die; 3930 write_runtime_sync
2891 3931 or warn "ERROR: unable to write runtime file: $!";
2892 $map->width (50);
2893 $map->height (50);
2894 $map->alloc;
2895 $map->_load_objects ("/tmp/x.map", 1);
2896 my $t = Event::time - $t;
2897
2898 #next unless $t < 0.0013;#d#
2899 if ($t < $min) {
2900 $min = $t;
2901 }
2902 $avg = $avg * 0.99 + $t * 0.01;
2903 }
2904 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2905 exit 0;
2906 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2907 }; 3932 };
3933 }
2908 3934
2909 $RUNTIME += $TICK;
2910 $NEXT_TICK += $TICK;
2911
2912 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2913 $NEXT_RUNTIME_WRITE = $NOW + 10;
2914 Coro::async_pool {
2915 write_runtime
2916 or warn "ERROR: unable to write runtime file: $!";
2917 };
2918 }
2919
2920# my $AFTER = Event::time;
2921# warn $AFTER - $NOW;#d#
2922
2923 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3935 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2924 $sig->send; 3936 $sig->send;
2925 } 3937 }
2926 while (my $sig = shift @WAIT_FOR_TICK) { 3938 while (my $sig = shift @WAIT_FOR_TICK) {
2927 $sig->send; 3939 $sig->send;
2928 } 3940 }
2929 3941
2930 $NOW = Event::time; 3942 $LOAD = ($NOW - $TICK_START) / $TICK;
2931
2932 # if we are delayed by four ticks or more, skip them all
2933 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2934
2935 $TICK_WATCHER->at ($NEXT_TICK);
2936 $TICK_WATCHER->start;
2937
2938 $LOAD = ($NOW - $tick_start) / $TICK;
2939 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3943 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2940 3944
2941 _post_tick; 3945 if (0) {
2942 3946 if ($NEXT_TICK) {
2943 3947 my $jitter = $TICK_START - $NEXT_TICK;
3948 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3949 warn "jitter $JITTER\n";#d#
3950 }
2944 }, 3951 }
2945); 3952}
2946 3953
2947{ 3954{
2948 BDB::max_poll_time $TICK * 0.1; 3955 # configure BDB
2949 $BDB_POLL_WATCHER = Event->io ( 3956
2950 reentrant => 0,
2951 fd => BDB::poll_fileno,
2952 poll => 'r',
2953 prio => 0,
2954 data => WF_AUTOCANCEL,
2955 cb => \&BDB::poll_cb,
2956 );
2957 BDB::min_parallel 8; 3957 BDB::min_parallel 8;
2958 3958 BDB::max_poll_reqs $TICK * 0.1;
2959 BDB::set_sync_prepare { 3959 $AnyEvent::BDB::WATCHER->priority (1);
2960 my $status;
2961 my $current = $Coro::current;
2962 (
2963 sub {
2964 $status = $!;
2965 $current->ready; undef $current;
2966 },
2967 sub {
2968 Coro::schedule while defined $current;
2969 $! = $status;
2970 },
2971 )
2972 };
2973 3960
2974 unless ($DB_ENV) { 3961 unless ($DB_ENV) {
2975 $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);
2976 3968
2977 cf::sync_job { 3969 cf::sync_job {
2978 eval { 3970 eval {
2979 BDB::db_env_open 3971 BDB::db_env_open
2980 $DB_ENV, 3972 $DB_ENV,
… …
2982 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
2983 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3975 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2984 0666; 3976 0666;
2985 3977
2986 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3978 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2987
2988 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2989 $DB_ENV->set_lk_detect;
2990 }; 3979 };
2991 3980
2992 cf::cleanup "db_env_open(db): $@" if $@; 3981 cf::cleanup "db_env_open(db): $@" if $@;
2993 }; 3982 };
2994 } 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 };
2995} 3994}
2996 3995
2997{ 3996{
3997 # configure IO::AIO
3998
2998 IO::AIO::min_parallel 8; 3999 IO::AIO::min_parallel 8;
2999
3000 undef $Coro::AIO::WATCHER;
3001 IO::AIO::max_poll_time $TICK * 0.1; 4000 IO::AIO::max_poll_time $TICK * 0.1;
3002 $AIO_POLL_WATCHER = Event->io ( 4001 undef $AnyEvent::AIO::WATCHER;
3003 reentrant => 0,
3004 data => WF_AUTOCANCEL,
3005 fd => IO::AIO::poll_fileno,
3006 poll => 'r',
3007 prio => 6,
3008 cb => \&IO::AIO::poll_cb,
3009 );
3010} 4002}
3011 4003
3012my $_log_backtrace; 4004my $_log_backtrace;
3013 4005
3014sub _log_backtrace { 4006sub _log_backtrace {
… …
3017 $msg =~ s/\n//; 4009 $msg =~ s/\n//;
3018 4010
3019 # limit the # of concurrent backtraces 4011 # limit the # of concurrent backtraces
3020 if ($_log_backtrace < 2) { 4012 if ($_log_backtrace < 2) {
3021 ++$_log_backtrace; 4013 ++$_log_backtrace;
4014 my $perl_bt = Carp::longmess $msg;
3022 async { 4015 async {
4016 $Coro::current->{desc} = "abt $msg";
4017
3023 my @bt = fork_call { 4018 my @bt = fork_call {
3024 @addr = map { sprintf "%x", $_ } @addr; 4019 @addr = map { sprintf "%x", $_ } @addr;
3025 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 4020 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3026 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 |"
3027 or die "addr2line: $!"; 4022 or die "addr2line: $!";
… …
3035 } 4030 }
3036 4031
3037 @funcs 4032 @funcs
3038 }; 4033 };
3039 4034
3040 LOG llevInfo, "[ABT] $msg\n"; 4035 LOG llevInfo, "[ABT] $perl_bt\n";
4036 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3041 LOG llevInfo, "[ABT] $_\n" for @bt; 4037 LOG llevInfo, "[ABT] $_\n" for @bt;
3042 --$_log_backtrace; 4038 --$_log_backtrace;
3043 }; 4039 };
3044 } else { 4040 } else {
3045 LOG llevInfo, "[ABT] $msg\n"; 4041 LOG llevInfo, "[ABT] $msg\n";
3046 LOG llevInfo, "[ABT] [suppressed]\n"; 4042 LOG llevInfo, "[ABT] [suppressed]\n";
3047 } 4043 }
3048} 4044}
3049 4045
3050# load additional modules 4046# load additional modules
3051use cf::pod; 4047require "cf/$_.pm" for @EXTRA_MODULES;
4048cf::_connect_to_perl_2;
3052 4049
3053END { cf::emergency_save } 4050END { cf::emergency_save }
3054 4051
30551 40521
3056 4053

Diff Legend

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