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

Diff Legend

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