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.269 by root, Tue May 22 21:35:26 2007 UTC vs.
Revision 1.407 by root, Sun Jan 13 09:53:53 2008 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use Storable; 9use EV 1.86;
10use Event;
11use Opcode; 10use Opcode;
12use Safe; 11use Safe;
13use Safe::Hole; 12use Safe::Hole;
13use Storable ();
14 14
15use Coro 3.61 (); 15use Coro 4.32 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::EV;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::BDB;
23use Coro::Storable; 24use Coro::Storable;
25use Coro::Util ();
24 26
27use JSON::XS 2.01 ();
25use BDB (); 28use BDB ();
26use Data::Dumper; 29use Data::Dumper;
27use Digest::MD5; 30use Digest::MD5;
28use Fcntl; 31use Fcntl;
29use YAML::Syck (); 32use YAML::Syck ();
30use IO::AIO 2.32 (); 33use IO::AIO 2.51 ();
31use Time::HiRes; 34use Time::HiRes;
32use Compress::LZF; 35use Compress::LZF;
36use Digest::MD5 ();
33 37
34# configure various modules to our taste 38# configure various modules to our taste
35# 39#
36$Storable::canonical = 1; # reduce rsync transfers 40$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 41Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 42Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39 43
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? 44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
43$YAML::Syck::ImplicitUnicode = 1; 45$YAML::Syck::ImplicitUnicode = 1;
44 46
45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46 48
… …
49our %COMMAND = (); 51our %COMMAND = ();
50our %COMMAND_TIME = (); 52our %COMMAND_TIME = ();
51 53
52our @EXTS = (); # list of extension package names 54our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 55our %EXTCMD = ();
56our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 57our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 58our %EXT_MAP = (); # pluggable maps
56 59
57our $RELOAD; # number of reloads so far 60our $RELOAD; # number of reloads so far
58our @EVENT; 61our @EVENT;
… …
66our $TMPDIR = "$LOCALDIR/" . tmpdir; 69our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir; 71our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random"; 72our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db"; 73our $BDBDIR = "$LOCALDIR/db";
74our %RESOURCE;
71 75
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
73our $TICK_WATCHER; 77our $TICK_WATCHER;
74our $AIO_POLL_WATCHER; 78our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
76our $NEXT_TICK; 80our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 81our $USE_FSYNC = 1; # use fsync to write maps - default off
79 82
80our $BDB_POLL_WATCHER; 83our $BDB_POLL_WATCHER;
84our $BDB_DEADLOCK_WATCHER;
85our $BDB_CHECKPOINT_WATCHER;
86our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 87our $DB_ENV;
82 88
83our %CFG; 89our %CFG;
84 90
85our $UPTIME; $UPTIME ||= time; 91our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 92our $RUNTIME;
93our $NOW;
87 94
88our %PLAYER; # all users 95our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 96our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 97our $LINK_MAP; # the special {link} map, which is always available
91 98
92# used to convert map paths into valid unix filenames by replacing / by ∕ 99# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 101
… …
155 162
156The raw value load value from the last tick. 163The raw value load value from the last tick.
157 164
158=item %cf::CFG 165=item %cf::CFG
159 166
160Configuration for the server, loaded from C</etc/crossfire/config>, or 167Configuration for the server, loaded from C</etc/deliantra-server/config>, or
161from wherever your confdir points to. 168from wherever your confdir points to.
162 169
163=item cf::wait_for_tick, cf::wait_for_tick_begin 170=item cf::wait_for_tick, cf::wait_for_tick_begin
164 171
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 172These 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 173returns 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. 174per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168 175
176=item @cf::INVOKE_RESULTS
177
178This array contains the results of the last C<invoke ()> call. When
179C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
180that call.
181
169=back 182=back
170 183
171=cut 184=cut
172 185
173BEGIN { 186BEGIN {
… …
177 $msg .= "\n" 190 $msg .= "\n"
178 unless $msg =~ /\n$/; 191 unless $msg =~ /\n$/;
179 192
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181 194
182 utf8::encode $msg;
183 LOG llevError, $msg; 195 LOG llevError, $msg;
184 }; 196 };
185} 197}
198
199$Coro::State::DIEHOOK = sub {
200 warn Carp::longmess $_[0];
201 Coro::terminate;
202};
186 203
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 204@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 205@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 206@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 207@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 208@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
209@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
192@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 210@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
193 211
194# we bless all objects into (empty) derived classes to force a method lookup 212# we bless all objects into (empty) derived classes to force a method lookup
195# within the Safe compartment. 213# within the Safe compartment.
196for my $pkg (qw( 214for my $pkg (qw(
197 cf::global cf::attachable 215 cf::global cf::attachable
… …
202)) { 220)) {
203 no strict 'refs'; 221 no strict 'refs';
204 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 222 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
205} 223}
206 224
207$Event::DIED = sub { 225$EV::DIED = sub {
208 warn "error in event callback: @_"; 226 warn "error in event callback: @_";
209}; 227};
228
229#############################################################################
210 230
211=head2 UTILITY FUNCTIONS 231=head2 UTILITY FUNCTIONS
212 232
213=over 4 233=over 4
214 234
… …
233 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 253 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
234 $d 254 $d
235 } || "[unable to dump $_[0]: '$@']"; 255 } || "[unable to dump $_[0]: '$@']";
236} 256}
237 257
238use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
239
240=item $ref = cf::from_json $json 258=item $ref = cf::decode_json $json
241 259
242Converts a JSON string into the corresponding perl data structure. 260Converts a JSON string into the corresponding perl data structure.
243 261
244=item $json = cf::to_json $ref 262=item $json = cf::encode_json $ref
245 263
246Converts a perl data structure into its JSON representation. 264Converts a perl data structure into its JSON representation.
265
266=cut
267
268our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
269
270sub encode_json($) { $json_coder->encode ($_[0]) }
271sub decode_json($) { $json_coder->decode ($_[0]) }
247 272
248=item cf::lock_wait $string 273=item cf::lock_wait $string
249 274
250Wait until the given lock is available. See cf::lock_acquire. 275Wait until the given lock is available. See cf::lock_acquire.
251 276
… …
254Wait until the given lock is available and then acquires it and returns 279Wait 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, 280a Coro::guard object. If the guard object gets destroyed (goes out of scope,
256for example when the coroutine gets canceled), the lock is automatically 281for example when the coroutine gets canceled), the lock is automatically
257returned. 282returned.
258 283
284Locks are *not* recursive, locking from the same coro twice results in a
285deadlocked coro.
286
259Lock names should begin with a unique identifier (for example, cf::map::find 287Lock names should begin with a unique identifier (for example, cf::map::find
260uses map_find and cf::map::load uses map_load). 288uses map_find and cf::map::load uses map_load).
261 289
262=item $locked = cf::lock_active $string 290=item $locked = cf::lock_active $string
263 291
264Return true if the lock is currently active, i.e. somebody has locked it. 292Return true if the lock is currently active, i.e. somebody has locked it.
265 293
266=cut 294=cut
267 295
268our %LOCK; 296our %LOCK;
297our %LOCKER;#d#
269 298
270sub lock_wait($) { 299sub lock_wait($) {
271 my ($key) = @_; 300 my ($key) = @_;
301
302 if ($LOCKER{$key} == $Coro::current) {#d#
303 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
304 return;#d#
305 }#d#
272 306
273 # wait for lock, if any 307 # wait for lock, if any
274 while ($LOCK{$key}) { 308 while ($LOCK{$key}) {
275 push @{ $LOCK{$key} }, $Coro::current; 309 push @{ $LOCK{$key} }, $Coro::current;
276 Coro::schedule; 310 Coro::schedule;
… …
282 316
283 # wait, to be sure we are not locked 317 # wait, to be sure we are not locked
284 lock_wait $key; 318 lock_wait $key;
285 319
286 $LOCK{$key} = []; 320 $LOCK{$key} = [];
321 $LOCKER{$key} = $Coro::current;#d#
287 322
288 Coro::guard { 323 Coro::guard {
324 delete $LOCKER{$key};#d#
289 # wake up all waiters, to be on the safe side 325 # wake up all waiters, to be on the safe side
290 $_->ready for @{ delete $LOCK{$key} }; 326 $_->ready for @{ delete $LOCK{$key} };
291 } 327 }
292} 328}
293 329
… …
305 }; 341 };
306 $TICK_WATCHER->stop; 342 $TICK_WATCHER->stop;
307 $guard 343 $guard
308} 344}
309 345
346=item cf::periodic $interval, $cb
347
348Like EV::periodic, but randomly selects a starting point so that the actions
349get spread over timer.
350
351=cut
352
353sub periodic($$) {
354 my ($interval, $cb) = @_;
355
356 my $start = rand List::Util::min 180, $interval;
357
358 EV::periodic $start, $interval, 0, $cb
359}
360
361=item cf::get_slot $time[, $priority[, $name]]
362
363Allocate $time seconds of blocking CPU time at priority C<$priority>:
364This call blocks and returns only when you have at least C<$time> seconds
365of cpu time till the next tick. The slot is only valid till the next cede.
366
367The optional C<$name> can be used to identify the job to run. It might be
368used for statistical purposes and should identify the same time-class.
369
370Useful for short background jobs.
371
372=cut
373
374our @SLOT_QUEUE;
375our $SLOT_QUEUE;
376
377$SLOT_QUEUE->cancel if $SLOT_QUEUE;
378$SLOT_QUEUE = Coro::async {
379 $Coro::current->desc ("timeslot manager");
380
381 my $signal = new Coro::Signal;
382
383 while () {
384 next_job:
385 my $avail = cf::till_tick;
386 if ($avail > 0.01) {
387 for (0 .. $#SLOT_QUEUE) {
388 if ($SLOT_QUEUE[$_][0] < $avail) {
389 my $job = splice @SLOT_QUEUE, $_, 1, ();
390 $job->[2]->send;
391 Coro::cede;
392 goto next_job;
393 }
394 }
395 }
396
397 if (@SLOT_QUEUE) {
398 # we do not use wait_for_tick() as it returns immediately when tick is inactive
399 push @cf::WAIT_FOR_TICK, $signal;
400 $signal->wait;
401 } else {
402 Coro::schedule;
403 }
404 }
405};
406
407sub get_slot($;$$) {
408 my ($time, $pri, $name) = @_;
409
410 $time = $TICK * .6 if $time > $TICK * .6;
411 my $sig = new Coro::Signal;
412
413 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
414 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
415 $SLOT_QUEUE->ready;
416 $sig->wait;
417}
418
310=item cf::async { BLOCK } 419=item cf::async { BLOCK }
311 420
312Currently the same as Coro::async_pool, meaning you cannot use 421Currently the same as Coro::async_pool, meaning you cannot use
313C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 422C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
314thing you are allowed to do is call C<prio> on it. 423thing you are allowed to do is call C<prio> on it.
… …
317 426
318BEGIN { *async = \&Coro::async_pool } 427BEGIN { *async = \&Coro::async_pool }
319 428
320=item cf::sync_job { BLOCK } 429=item cf::sync_job { BLOCK }
321 430
322The design of crossfire+ requires that the main coro ($Coro::main) is 431The design of Deliantra requires that the main coroutine ($Coro::main)
323always able to handle events or runnable, as crossfire+ is only partly 432is 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. 433partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
434acceptable.
325 435
326If it must be done, put the blocking parts into C<sync_job>. This will run 436If 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 437the given BLOCK in another coroutine while waiting for the result. The
328server will be frozen during this time, so the block should either finish 438server will be frozen during this time, so the block should either finish
329fast or be very important. 439fast or be very important.
… …
332 442
333sub sync_job(&) { 443sub sync_job(&) {
334 my ($job) = @_; 444 my ($job) = @_;
335 445
336 if ($Coro::current == $Coro::main) { 446 if ($Coro::current == $Coro::main) {
337 my $time = Event::time; 447 my $time = EV::time;
338 448
339 # this is the main coro, too bad, we have to block 449 # this is the main coro, too bad, we have to block
340 # till the operation succeeds, freezing the server :/ 450 # till the operation succeeds, freezing the server :/
341 451
452 LOG llevError, Carp::longmess "sync job";#d#
453
342 # TODO: use suspend/resume instead 454 # TODO: use suspend/resume instead
343 # (but this is cancel-safe) 455 # (but this is cancel-safe)
344 my $freeze_guard = freeze_mainloop; 456 my $freeze_guard = freeze_mainloop;
345 457
346 my $busy = 1; 458 my $busy = 1;
347 my @res; 459 my @res;
348 460
349 (async { 461 (async {
462 $Coro::current->desc ("sync job coro");
350 @res = eval { $job->() }; 463 @res = eval { $job->() };
351 warn $@ if $@; 464 warn $@ if $@;
352 undef $busy; 465 undef $busy;
353 })->prio (Coro::PRIO_MAX); 466 })->prio (Coro::PRIO_MAX);
354 467
355 while ($busy) { 468 while ($busy) {
356 Coro::cede or Event::one_event; 469 if (Coro::nready) {
470 Coro::cede_notself;
471 } else {
472 EV::loop EV::LOOP_ONESHOT;
357 } 473 }
474 }
358 475
359 $time = Event::time - $time; 476 $time = EV::time - $time;
360 477
361 LOG llevError | logBacktrace, Carp::longmess "long sync job" 478 LOG llevError | logBacktrace, Carp::longmess "long sync job"
362 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 479 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
363 480
364 $tick_start += $time; # do not account sync jobs to server load 481 $tick_start += $time; # do not account sync jobs to server load
… …
389 $EXT_CORO{$coro+0} = $coro; 506 $EXT_CORO{$coro+0} = $coro;
390 507
391 $coro 508 $coro
392} 509}
393 510
394sub write_runtime { 511=item fork_call { }, $args
395 my $runtime = "$LOCALDIR/runtime";
396 512
397 # first touch the runtime file to show we are still running: 513Executes the given code block with the given arguments in a seperate
398 # the fsync below can take a very very long time. 514process, returning the results. Everything must be serialisable with
515Coro::Storable. May, of course, block. Note that the executed sub may
516never block itself or use any form of event handling.
399 517
400 if (my $fh = aio_open $runtime, O_WRONLY, 0) { 518=cut
401 utime undef, undef, $fh; 519
520sub fork_call(&@) {
521 my ($cb, @args) = @_;
522
523 # we seemingly have to make a local copy of the whole thing,
524 # otherwise perl prematurely frees the stuff :/
525 # TODO: investigate and fix (likely this will be rather laborious)
526
527 my @res = Coro::Util::fork_eval {
528 reset_signals;
529 &$cb
530 }, @args;
531
532 wantarray ? @res : $res[-1]
533}
534
535=item $value = cf::db_get $family => $key
536
537Returns a single value from the environment database.
538
539=item cf::db_put $family => $key => $value
540
541Stores the given C<$value> in the family. It can currently store binary
542data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
543
544=item $db = cf::db_table "name"
545
546Create and/or open a new database table. The string must not be "db" and must be unique
547within each server.
548
549=cut
550
551sub db_table($) {
552 my ($name) = @_;
553 my $db = BDB::db_create $DB_ENV;
554
555 eval {
556 $db->set_flags (BDB::CHKSUM);
557
558 utf8::encode $name;
559 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
560 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
561 cf::cleanup "db_open(db): $!" if $!;
402 } 562 };
563 cf::cleanup "db_open(db): $@" if $@;
403 564
404 my $guard = cf::lock_acquire "write_runtime"; 565 $db
566}
405 567
406 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 568our $DB;
407 or return;
408 569
409 my $value = $cf::RUNTIME + 90 + 10; 570sub db_init {
410 # 10 is the runtime save interval, for a monotonic clock 571 cf::sync_job {
411 # 60 allows for the watchdog to kill the server. 572 $DB ||= db_table "db";
573 };
574}
412 575
413 (aio_write $fh, 0, (length $value), $value, 0) <= 0 576sub db_get($$) {
414 and return; 577 my $key = "$_[0]/$_[1]";
415 578
416 # always fsync - this file is important 579 cf::sync_job {
417 aio_fsync $fh 580 BDB::db_get $DB, undef, $key, my $data;
418 and return;
419 581
420 # touch it again to show we are up-to-date 582 $! ? ()
421 utime undef, undef, $fh; 583 : $data
422
423 close $fh
424 or return;
425
426 aio_rename "$runtime~", $runtime
427 and return;
428
429 warn "runtime file written.\n";#d#
430
431 1 584 }
585}
586
587sub db_put($$$) {
588 BDB::dbreq_pri 4;
589 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
590}
591
592=item cf::cache $id => [$paths...], $processversion => $process
593
594Generic caching function that returns the value of the resource $id,
595caching and regenerating as required.
596
597This function can block.
598
599=cut
600
601sub cache {
602 my ($id, $src, $processversion, $process) = @_;
603
604 my $meta =
605 join "\x00",
606 $processversion,
607 map {
608 aio_stat $_
609 and Carp::croak "$_: $!";
610
611 ($_, (stat _)[7,9])
612 } @$src;
613
614 my $dbmeta = db_get cache => "$id/meta";
615 if ($dbmeta ne $meta) {
616 # changed, we may need to process
617
618 my @data;
619 my $md5;
620
621 for (0 .. $#$src) {
622 0 <= aio_load $src->[$_], $data[$_]
623 or Carp::croak "$src->[$_]: $!";
624 }
625
626 # if processing is expensive, check
627 # checksum first
628 if (1) {
629 $md5 =
630 join "\x00",
631 $processversion,
632 map {
633 cf::cede_to_tick;
634 ($src->[$_], Digest::MD5::md5_hex $data[$_])
635 } 0.. $#$src;
636
637
638 my $dbmd5 = db_get cache => "$id/md5";
639 if ($dbmd5 eq $md5) {
640 db_put cache => "$id/meta", $meta;
641
642 return db_get cache => "$id/data";
643 }
644 }
645
646 my $t1 = Time::HiRes::time;
647 my $data = $process->(\@data);
648 my $t2 = Time::HiRes::time;
649
650 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
651
652 db_put cache => "$id/data", $data;
653 db_put cache => "$id/md5" , $md5;
654 db_put cache => "$id/meta", $meta;
655
656 return $data;
657 }
658
659 db_get cache => "$id/data"
432} 660}
433 661
434=item cf::datalog type => key => value, ... 662=item cf::datalog type => key => value, ...
435 663
436Log a datalog packet of the given type with the given key-value pairs. 664Log a datalog packet of the given type with the given key-value pairs.
… …
454attach callbacks/event handlers (a collection of which is called an "attachment") 682attach callbacks/event handlers (a collection of which is called an "attachment")
455to it. All such attachable objects support the following methods. 683to it. All such attachable objects support the following methods.
456 684
457In the following description, CLASS can be any of C<global>, C<object> 685In the following description, CLASS can be any of C<global>, C<object>
458C<player>, C<client> or C<map> (i.e. the attachable objects in 686C<player>, C<client> or C<map> (i.e. the attachable objects in
459crossfire+). 687Deliantra).
460 688
461=over 4 689=over 4
462 690
463=item $attachable->attach ($attachment, key => $value...) 691=item $attachable->attach ($attachment, key => $value...)
464 692
… …
666 _attach $registry, $klass, @attach; 894 _attach $registry, $klass, @attach;
667 } 895 }
668 896
669 $obj->{$name} = \%arg; 897 $obj->{$name} = \%arg;
670 } else { 898 } else {
671 warn "object uses attachment '$name' that is not available, postponing.\n"; 899 warn "object uses attachment '$name' which is not available, postponing.\n";
672 } 900 }
673 901
674 $obj->{_attachment}{$name} = undef; 902 $obj->{_attachment}{$name} = undef;
675} 903}
676 904
… …
716 "; 944 ";
717 die if $@; 945 die if $@;
718} 946}
719 947
720our $override; 948our $override;
721our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 949our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
722 950
723sub override { 951sub override {
724 $override = 1; 952 $override = 1;
725 @invoke_results = (); 953 @INVOKE_RESULTS = (@_);
726} 954}
727 955
728sub do_invoke { 956sub do_invoke {
729 my $event = shift; 957 my $event = shift;
730 my $callbacks = shift; 958 my $callbacks = shift;
731 959
732 @invoke_results = (); 960 @INVOKE_RESULTS = ();
733 961
734 local $override; 962 local $override;
735 963
736 for (@$callbacks) { 964 for (@$callbacks) {
737 eval { &{$_->[1]} }; 965 eval { &{$_->[1]} };
… …
746 } 974 }
747 975
748 0 976 0
749} 977}
750 978
751=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 979=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
752 980
753=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 981=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
754 982
755Generate an object-specific event with the given arguments. 983Generate an object-specific event with the given arguments.
756 984
757This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 985This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
758removed in future versions), and there is no public API to access override 986removed in future versions), and there is no public API to access override
759results (if you must, access C<@cf::invoke_results> directly). 987results (if you must, access C<@cf::INVOKE_RESULTS> directly).
760 988
761=back 989=back
762 990
763=cut 991=cut
764 992
765############################################################################# 993#############################################################################
766# object support 994# object support
995
996sub _object_equal($$);
997sub _object_equal($$) {
998 my ($a, $b) = @_;
999
1000 return 0 unless (ref $a) eq (ref $b);
1001
1002 if ("HASH" eq ref $a) {
1003 my @ka = keys %$a;
1004 my @kb = keys %$b;
1005
1006 return 0 if @ka != @kb;
1007
1008 for (0 .. $#ka) {
1009 return 0 unless $ka[$_] eq $kb[$_];
1010 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1011 }
1012
1013 } elsif ("ARRAY" eq ref $a) {
1014
1015 return 0 if @$a != @$b;
1016
1017 for (0 .. $#$a) {
1018 return 0 unless _object_equal $a->[$_], $b->[$_];
1019 }
1020
1021 } elsif ($a ne $b) {
1022 return 0;
1023 }
1024
1025 1
1026}
1027
1028our $SLOW_MERGES;#d#
1029sub _can_merge {
1030 my ($ob1, $ob2) = @_;
1031
1032 ++$SLOW_MERGES;#d#
1033
1034 # we do the slow way here
1035 return _object_equal $ob1, $ob2
1036}
767 1037
768sub reattach { 1038sub reattach {
769 # basically do the same as instantiate, without calling instantiate 1039 # basically do the same as instantiate, without calling instantiate
770 my ($obj) = @_; 1040 my ($obj) = @_;
771 1041
… …
792cf::attachable->attach ( 1062cf::attachable->attach (
793 prio => -1000000, 1063 prio => -1000000,
794 on_instantiate => sub { 1064 on_instantiate => sub {
795 my ($obj, $data) = @_; 1065 my ($obj, $data) = @_;
796 1066
797 $data = from_json $data; 1067 $data = decode_json $data;
798 1068
799 for (@$data) { 1069 for (@$data) {
800 my ($name, $args) = @$_; 1070 my ($name, $args) = @$_;
801 1071
802 $obj->attach ($name, %{$args || {} }); 1072 $obj->attach ($name, %{$args || {} });
… …
818sub object_freezer_save { 1088sub object_freezer_save {
819 my ($filename, $rdata, $objs) = @_; 1089 my ($filename, $rdata, $objs) = @_;
820 1090
821 sync_job { 1091 sync_job {
822 if (length $$rdata) { 1092 if (length $$rdata) {
1093 utf8::decode (my $decname = $filename);
823 warn sprintf "saving %s (%d,%d)\n", 1094 warn sprintf "saving %s (%d,%d)\n",
824 $filename, length $$rdata, scalar @$objs; 1095 $decname, length $$rdata, scalar @$objs;
825 1096
826 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1097 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
827 chmod SAVE_MODE, $fh; 1098 chmod SAVE_MODE, $fh;
828 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1099 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
829 aio_fsync $fh if $cf::USE_FSYNC; 1100 aio_fsync $fh if $cf::USE_FSYNC;
830 close $fh; 1101 close $fh;
831 1102
832 if (@$objs) { 1103 if (@$objs) {
833 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1104 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
834 chmod SAVE_MODE, $fh; 1105 chmod SAVE_MODE, $fh;
835 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1106 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
836 aio_write $fh, 0, (length $data), $data, 0; 1107 aio_write $fh, 0, (length $data), $data, 0;
837 aio_fsync $fh if $cf::USE_FSYNC; 1108 aio_fsync $fh if $cf::USE_FSYNC;
838 close $fh; 1109 close $fh;
839 aio_rename "$filename.pst~", "$filename.pst"; 1110 aio_rename "$filename.pst~", "$filename.pst";
840 } 1111 }
… …
848 } 1119 }
849 } else { 1120 } else {
850 aio_unlink $filename; 1121 aio_unlink $filename;
851 aio_unlink "$filename.pst"; 1122 aio_unlink "$filename.pst";
852 } 1123 }
853 } 1124 };
854} 1125}
855 1126
856sub object_freezer_as_string { 1127sub object_freezer_as_string {
857 my ($rdata, $objs) = @_; 1128 my ($rdata, $objs) = @_;
858 1129
… …
870 or return; 1141 or return;
871 1142
872 unless (aio_stat "$filename.pst") { 1143 unless (aio_stat "$filename.pst") {
873 (aio_load "$filename.pst", $av) >= 0 1144 (aio_load "$filename.pst", $av) >= 0
874 or return; 1145 or return;
1146
875 $av = eval { (Storable::thaw $av)->{objs} }; 1147 my $st = eval { Coro::Storable::thaw $av };
1148 $av = $st->{objs};
876 } 1149 }
877 1150
1151 utf8::decode (my $decname = $filename);
878 warn sprintf "loading %s (%d)\n", 1152 warn sprintf "loading %s (%d,%d)\n",
879 $filename, length $data, scalar @{$av || []};#d# 1153 $decname, length $data, scalar @{$av || []};
1154
880 return ($data, $av); 1155 ($data, $av)
881} 1156}
1157
1158=head2 COMMAND CALLBACKS
1159
1160=over 4
1161
1162=cut
882 1163
883############################################################################# 1164#############################################################################
884# command handling &c 1165# command handling &c
885 1166
886=item cf::register_command $name => \&callback($ob,$args); 1167=item cf::register_command $name => \&callback($ob,$args);
… …
899 push @{ $COMMAND{$name} }, [$caller, $cb]; 1180 push @{ $COMMAND{$name} }, [$caller, $cb];
900} 1181}
901 1182
902=item cf::register_extcmd $name => \&callback($pl,$packet); 1183=item cf::register_extcmd $name => \&callback($pl,$packet);
903 1184
904Register a callbackf ro execution when the client sends an extcmd packet. 1185Register a callback for execution when the client sends an (synchronous)
1186extcmd packet. Ext commands will be processed in the order they are
1187received by the server, like other user commands. The first argument is
1188the logged-in player. Ext commands can only be processed after a player
1189has logged in successfully.
905 1190
906If the callback returns something, it is sent back as if reply was being 1191If the callback returns something, it is sent back as if reply was being
907called. 1192called.
908 1193
1194=item cf::register_exticmd $name => \&callback($ns,$packet);
1195
1196Register a callback for execution when the client sends an (asynchronous)
1197exticmd packet. Exti commands are processed by the server as soon as they
1198are received, i.e. out of order w.r.t. other commands. The first argument
1199is a client socket. Exti commands can be received anytime, even before
1200log-in.
1201
1202If the callback returns something, it is sent back as if reply was being
1203called.
1204
909=cut 1205=cut
910 1206
911sub register_extcmd { 1207sub register_extcmd {
912 my ($name, $cb) = @_; 1208 my ($name, $cb) = @_;
913 1209
914 $EXTCMD{$name} = $cb; 1210 $EXTCMD{$name} = $cb;
1211}
1212
1213sub register_exticmd {
1214 my ($name, $cb) = @_;
1215
1216 $EXTICMD{$name} = $cb;
915} 1217}
916 1218
917cf::player->attach ( 1219cf::player->attach (
918 on_command => sub { 1220 on_command => sub {
919 my ($pl, $name, $params) = @_; 1221 my ($pl, $name, $params) = @_;
… …
928 cf::override; 1230 cf::override;
929 }, 1231 },
930 on_extcmd => sub { 1232 on_extcmd => sub {
931 my ($pl, $buf) = @_; 1233 my ($pl, $buf) = @_;
932 1234
933 my $msg = eval { from_json $buf }; 1235 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
934 1236
935 if (ref $msg) { 1237 if (ref $msg) {
1238 my ($type, $reply, @payload) =
1239 "ARRAY" eq ref $msg
1240 ? @$msg
1241 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1242
1243 my @reply;
1244
936 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1245 if (my $cb = $EXTCMD{$type}) {
937 if (my %reply = $cb->($pl, $msg)) { 1246 @reply = $cb->($pl, @payload);
938 $pl->ext_reply ($msg->{msgid}, %reply);
939 }
940 } 1247 }
1248
1249 $pl->ext_reply ($reply, @reply)
1250 if $reply;
1251
941 } else { 1252 } else {
942 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1253 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
943 } 1254 }
944 1255
945 cf::override; 1256 cf::override;
946 }, 1257 },
947); 1258);
948 1259
949sub load_extension {
950 my ($path) = @_;
951
952 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
953 my $base = $1;
954 my $pkg = $1;
955 $pkg =~ s/[^[:word:]]/_/g;
956 $pkg = "ext::$pkg";
957
958 warn "... loading '$path' into '$pkg'\n";
959
960 open my $fh, "<:utf8", $path
961 or die "$path: $!";
962
963 my $source =
964 "package $pkg; use strict; use utf8;\n"
965 . "#line 1 \"$path\"\n{\n"
966 . (do { local $/; <$fh> })
967 . "\n};\n1";
968
969 unless (eval $source) {
970 my $msg = $@ ? "$path: $@\n"
971 : "extension disabled.\n";
972 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
973 warn $@;
974 warn "mandatory extension failed to load, exiting.\n";
975 exit 1;
976 }
977 die $@;
978 }
979
980 push @EXTS, $pkg;
981}
982
983sub load_extensions { 1260sub load_extensions {
1261 cf::sync_job {
1262 my %todo;
1263
984 for my $ext (<$LIBDIR/*.ext>) { 1264 for my $path (<$LIBDIR/*.ext>) {
985 next unless -r $ext; 1265 next unless -r $path;
986 eval { 1266
987 load_extension $ext; 1267 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1268 my $base = $1;
1269 my $pkg = $1;
1270 $pkg =~ s/[^[:word:]]/_/g;
1271 $pkg = "ext::$pkg";
1272
1273 open my $fh, "<:utf8", $path
1274 or die "$path: $!";
1275
1276 my $source = do { local $/; <$fh> };
1277
1278 my %ext = (
1279 path => $path,
1280 base => $base,
1281 pkg => $pkg,
1282 );
1283
1284 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1285 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1286
1287 $ext{source} =
1288 "package $pkg; use strict; use utf8;\n"
1289 . "#line 1 \"$path\"\n{\n"
1290 . $source
1291 . "\n};\n1";
1292
1293 $todo{$base} = \%ext;
1294 }
1295
1296 my %done;
1297 while (%todo) {
1298 my $progress;
1299
1300 while (my ($k, $v) = each %todo) {
1301 for (split /,\s*/, $v->{meta}{depends}) {
1302 goto skip
1303 unless exists $done{$_};
1304 }
1305
1306 warn "... loading '$k' into '$v->{pkg}'\n";
1307
1308 unless (eval $v->{source}) {
1309 my $msg = $@ ? "$v->{path}: $@\n"
1310 : "$v->{base}: extension inactive.\n";
1311
1312 if (exists $v->{meta}{mandatory}) {
1313 warn $msg;
1314 warn "mandatory extension failed to load, exiting.\n";
1315 exit 1;
1316 }
1317
1318 warn $msg;
1319 }
1320
1321 $done{$k} = delete $todo{$k};
1322 push @EXTS, $v->{pkg};
1323 $progress = 1;
988 1 1324 }
989 } or warn "$ext not loaded: $@"; 1325
1326 skip:
1327 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1328 unless $progress;
1329 }
990 } 1330 };
991} 1331}
992 1332
993############################################################################# 1333#############################################################################
994 1334
1335=back
1336
995=head2 CORE EXTENSIONS 1337=head2 CORE EXTENSIONS
996 1338
997Functions and methods that extend core crossfire objects. 1339Functions and methods that extend core crossfire objects.
998 1340
999=cut 1341=cut
… …
1003use Coro::AIO; 1345use Coro::AIO;
1004 1346
1005=head3 cf::player 1347=head3 cf::player
1006 1348
1007=over 4 1349=over 4
1350
1351=item cf::player::num_playing
1352
1353Returns the official number of playing players, as per the Crossfire metaserver rules.
1354
1355=cut
1356
1357sub num_playing {
1358 scalar grep
1359 $_->ob->map
1360 && !$_->hidden
1361 && !$_->ob->flag (cf::FLAG_WIZ),
1362 cf::player::list
1363}
1008 1364
1009=item cf::player::find $login 1365=item cf::player::find $login
1010 1366
1011Returns the given player object, loading it if necessary (might block). 1367Returns the given player object, loading it if necessary (might block).
1012 1368
… …
1048 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1404 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1049 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1405 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1050 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1406 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1051 aio_unlink +(playerdir $login) . "/$login.pl"; 1407 aio_unlink +(playerdir $login) . "/$login.pl";
1052 1408
1053 my $pl = load_pl path $login 1409 my $f = new_from_file cf::object::thawer path $login
1054 or return; 1410 or return;
1411
1412 my $pl = cf::player::load_pl $f
1413 or return;
1414 local $cf::PLAYER_LOADING{$login} = $pl;
1415 $f->resolve_delayed_derefs;
1055 $cf::PLAYER{$login} = $pl 1416 $cf::PLAYER{$login} = $pl
1056 } 1417 }
1057 } 1418 }
1058} 1419}
1059 1420
… …
1069 1430
1070 aio_mkdir playerdir $pl, 0770; 1431 aio_mkdir playerdir $pl, 0770;
1071 $pl->{last_save} = $cf::RUNTIME; 1432 $pl->{last_save} = $cf::RUNTIME;
1072 1433
1073 $pl->save_pl ($path); 1434 $pl->save_pl ($path);
1074 Coro::cede; 1435 cf::cede_to_tick;
1075} 1436}
1076 1437
1077sub new($) { 1438sub new($) {
1078 my ($login) = @_; 1439 my ($login) = @_;
1079 1440
… …
1083 $self->{deny_save} = 1; 1444 $self->{deny_save} = 1;
1084 1445
1085 $cf::PLAYER{$login} = $self; 1446 $cf::PLAYER{$login} = $self;
1086 1447
1087 $self 1448 $self
1449}
1450
1451=item $player->send_msg ($channel, $msg, $color, [extra...])
1452
1453=cut
1454
1455sub send_msg {
1456 my $ns = shift->ns
1457 or return;
1458 $ns->send_msg (@_);
1088} 1459}
1089 1460
1090=item $pl->quit_character 1461=item $pl->quit_character
1091 1462
1092Nukes the player without looking back. If logged in, the connection will 1463Nukes the player without looking back. If logged in, the connection will
… …
1147 or return []; 1518 or return [];
1148 1519
1149 my @logins; 1520 my @logins;
1150 1521
1151 for my $login (@$dirs) { 1522 for my $login (@$dirs) {
1523 my $path = path $login;
1524
1525 # a .pst is a dead give-away for a valid player
1526 unless (-e "$path.pst") {
1152 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1527 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1153 aio_read $fh, 0, 512, my $buf, 0 or next; 1528 aio_read $fh, 0, 512, my $buf, 0 or next;
1154 $buf !~ /^password -------------$/m or next; # official not-valid tag 1529 $buf !~ /^password -------------$/m or next; # official not-valid tag
1530 }
1155 1531
1156 utf8::decode $login; 1532 utf8::decode $login;
1157 push @logins, $login; 1533 push @logins, $login;
1158 } 1534 }
1159 1535
… …
1186 } 1562 }
1187 1563
1188 \@paths 1564 \@paths
1189} 1565}
1190 1566
1567=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1568
1569Expand crossfire pod fragments into protocol xml.
1570
1571=cut
1572
1573use re 'eval';
1574
1575my $group;
1576my $interior; $interior = qr{
1577 # match a pod interior sequence sans C<< >>
1578 (?:
1579 \ (.*?)\ (?{ $group = $^N })
1580 | < (??{$interior}) >
1581 )
1582}x;
1583
1584sub expand_cfpod {
1585 my ($self, $pod) = @_;
1586
1587 my $xml;
1588
1589 while () {
1590 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1591 $group = $1;
1592
1593 $group =~ s/&/&amp;/g;
1594 $group =~ s/</&lt;/g;
1595
1596 $xml .= $group;
1597 } elsif ($pod =~ m%\G
1598 ([BCGHITU])
1599 <
1600 (?:
1601 ([^<>]*) (?{ $group = $^N })
1602 | < $interior >
1603 )
1604 >
1605 %gcsx
1606 ) {
1607 my ($code, $data) = ($1, $group);
1608
1609 if ($code eq "B") {
1610 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1611 } elsif ($code eq "I") {
1612 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1613 } elsif ($code eq "U") {
1614 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1615 } elsif ($code eq "C") {
1616 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1617 } elsif ($code eq "T") {
1618 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1619 } elsif ($code eq "G") {
1620 my ($male, $female) = split /\|/, $data;
1621 $data = $self->gender ? $female : $male;
1622 $xml .= expand_cfpod ($self, $data);
1623 } elsif ($code eq "H") {
1624 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1625 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1626 "")
1627 [$self->{hintmode}];
1628 } else {
1629 $xml .= "error processing '$code($data)' directive";
1630 }
1631 } else {
1632 if ($pod =~ /\G(.+)/) {
1633 warn "parse error while expanding $pod (at $1)";
1634 }
1635 last;
1636 }
1637 }
1638
1639 for ($xml) {
1640 # create single paragraphs (very hackish)
1641 s/(?<=\S)\n(?=\w)/ /g;
1642
1643 # compress some whitespace
1644 s/\s+\n/\n/g; # ws line-ends
1645 s/\n\n+/\n/g; # double lines
1646 s/^\n+//; # beginning lines
1647 s/\n+$//; # ending lines
1648 }
1649
1650 $xml
1651}
1652
1653no re 'eval';
1654
1655sub hintmode {
1656 $_[0]{hintmode} = $_[1] if @_ > 1;
1657 $_[0]{hintmode}
1658}
1659
1191=item $player->ext_reply ($msgid, %msg) 1660=item $player->ext_reply ($msgid, @msg)
1192 1661
1193Sends an ext reply to the player. 1662Sends an ext reply to the player.
1194 1663
1195=cut 1664=cut
1196 1665
1197sub ext_reply($$%) { 1666sub ext_reply($$@) {
1198 my ($self, $id, %msg) = @_; 1667 my ($self, $id, @msg) = @_;
1199 1668
1200 $msg{msgid} = $id; 1669 $self->ns->ext_reply ($id, @msg)
1201
1202 $self->send ("ext " . cf::to_json \%msg);
1203} 1670}
1204 1671
1205=item $player->ext_event ($type, %msg) 1672=item $player->ext_msg ($type, @msg)
1206 1673
1207Sends an ext event to the client. 1674Sends an ext event to the client.
1208 1675
1209=cut 1676=cut
1210 1677
1211sub ext_event($$%) { 1678sub ext_msg($$@) {
1212 my ($self, $type, %msg) = @_; 1679 my ($self, $type, @msg) = @_;
1213 1680
1214 $self->ns->ext_event ($type, %msg); 1681 $self->ns->ext_msg ($type, @msg);
1215} 1682}
1216 1683
1217=head3 cf::region 1684=head3 cf::region
1218 1685
1219=over 4 1686=over 4
… …
1222 1689
1223package cf::region; 1690package cf::region;
1224 1691
1225=item cf::region::find_by_path $path 1692=item cf::region::find_by_path $path
1226 1693
1227Tries to decuce the probable region for a map knowing only its path. 1694Tries to decuce the likely region for a map knowing only its path.
1228 1695
1229=cut 1696=cut
1230 1697
1231sub find_by_path($) { 1698sub find_by_path($) {
1232 my ($path) = @_; 1699 my ($path) = @_;
1233 1700
1234 my ($match, $specificity); 1701 my ($match, $specificity);
1235 1702
1236 for my $region (list) { 1703 for my $region (list) {
1237 if ($region->match && $path =~ $region->match) { 1704 if ($region->{match} && $path =~ $region->{match}) {
1238 ($match, $specificity) = ($region, $region->specificity) 1705 ($match, $specificity) = ($region, $region->specificity)
1239 if $region->specificity > $specificity; 1706 if $region->specificity > $specificity;
1240 } 1707 }
1241 } 1708 }
1242 1709
… …
1306 my ($self, $merge) = @_; 1773 my ($self, $merge) = @_;
1307 1774
1308 # we have to keep some variables in memory intact 1775 # we have to keep some variables in memory intact
1309 local $self->{path}; 1776 local $self->{path};
1310 local $self->{load_path}; 1777 local $self->{load_path};
1311 local $self->{deny_save};
1312 local $self->{deny_reset};
1313 1778
1314 $self->SUPER::thawer_merge ($merge); 1779 $self->SUPER::thawer_merge ($merge);
1315} 1780}
1316 1781
1317sub normalise { 1782sub normalise {
… …
1364 $self->init; # pass $1 etc. 1829 $self->init; # pass $1 etc.
1365 return $self; 1830 return $self;
1366 } 1831 }
1367 } 1832 }
1368 1833
1369 Carp::carp "unable to resolve path '$path' (base '$base')."; 1834 Carp::cluck "unable to resolve path '$path' (base '$base').";
1370 () 1835 ()
1371} 1836}
1372 1837
1373sub init { 1838sub init {
1374 my ($self) = @_; 1839 my ($self) = @_;
… …
1417 1882
1418 $_->change_map_light ($change) 1883 $_->change_map_light ($change)
1419 for grep $_->outdoor, values %cf::MAP; 1884 for grep $_->outdoor, values %cf::MAP;
1420} 1885}
1421 1886
1887sub decay_objects {
1888 my ($self) = @_;
1889
1890 return if $self->{deny_reset};
1891
1892 $self->do_decay_objects;
1893}
1894
1422sub unlink_save { 1895sub unlink_save {
1423 my ($self) = @_; 1896 my ($self) = @_;
1424 1897
1425 utf8::encode (my $save = $self->save_path); 1898 utf8::encode (my $save = $self->save_path);
1426 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1899 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1429 1902
1430sub load_header_from($) { 1903sub load_header_from($) {
1431 my ($self, $path) = @_; 1904 my ($self, $path) = @_;
1432 1905
1433 utf8::encode $path; 1906 utf8::encode $path;
1434 #aio_open $path, O_RDONLY, 0 1907 my $f = new_from_file cf::object::thawer $path
1435 # or return;
1436
1437 $self->_load_header ($path)
1438 or return; 1908 or return;
1909
1910 $self->_load_header ($f)
1911 or return;
1912
1913 local $MAP_LOADING{$self->{path}} = $self;
1914 $f->resolve_delayed_derefs;
1439 1915
1440 $self->{load_path} = $path; 1916 $self->{load_path} = $path;
1441 1917
1442 1 1918 1
1443} 1919}
… …
1482 $self->load_header_orig 1958 $self->load_header_orig
1483 or return; 1959 or return;
1484 $self->prepare_orig; 1960 $self->prepare_orig;
1485 } 1961 }
1486 1962
1963 $self->{deny_reset} = 1
1964 if $self->no_reset;
1965
1487 $self->default_region (cf::region::find_by_path $self->{path}) 1966 $self->default_region (cf::region::find_by_path $self->{path})
1488 unless $self->default_region; 1967 unless $self->default_region;
1489 1968
1490 1 1969 1
1491} 1970}
… …
1494sub find { 1973sub find {
1495 my ($path, $origin) = @_; 1974 my ($path, $origin) = @_;
1496 1975
1497 $path = normalise $path, $origin && $origin->path; 1976 $path = normalise $path, $origin && $origin->path;
1498 1977
1978 cf::lock_wait "map_data:$path";#d#remove
1499 cf::lock_wait "map_find:$path"; 1979 cf::lock_wait "map_find:$path";
1500 1980
1501 $cf::MAP{$path} || do { 1981 $cf::MAP{$path} || do {
1502 my $guard = cf::lock_acquire "map_find:$path"; 1982 my $guard1 = cf::lock_acquire "map_find:$path";
1983 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1984
1503 my $map = new_from_path cf::map $path 1985 my $map = new_from_path cf::map $path
1504 or return; 1986 or return;
1505 1987
1506 $map->{last_save} = $cf::RUNTIME; 1988 $map->{last_save} = $cf::RUNTIME;
1507 1989
1508 $map->load_header 1990 $map->load_header
1509 or return; 1991 or return;
1510 1992
1511 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1993 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1512 # doing this can freeze the server in a sync job, obviously 1994 # doing this can freeze the server in a sync job, obviously
1513 #$cf::WAIT_FOR_TICK->wait; 1995 #$cf::WAIT_FOR_TICK->wait;
1996 undef $guard1;
1997 undef $guard2;
1514 $map->reset; 1998 $map->reset;
1515 undef $guard;
1516 return find $path; 1999 return find $path;
1517 } 2000 }
1518 2001
1519 $cf::MAP{$path} = $map 2002 $cf::MAP{$path} = $map
1520 } 2003 }
… …
1529 local $self->{deny_reset} = 1; # loading can take a long time 2012 local $self->{deny_reset} = 1; # loading can take a long time
1530 2013
1531 my $path = $self->{path}; 2014 my $path = $self->{path};
1532 2015
1533 { 2016 {
1534 my $guard = cf::lock_acquire "map_load:$path"; 2017 my $guard = cf::lock_acquire "map_data:$path";
1535 2018
2019 return unless $self->valid;
1536 return if $self->in_memory != cf::MAP_SWAPPED; 2020 return unless $self->in_memory == cf::MAP_SWAPPED;
1537 2021
1538 $self->in_memory (cf::MAP_LOADING); 2022 $self->in_memory (cf::MAP_LOADING);
1539 2023
1540 $self->alloc; 2024 $self->alloc;
1541 2025
1542 $self->pre_load; 2026 $self->pre_load;
1543 Coro::cede; 2027 cf::cede_to_tick;
1544 2028
2029 my $f = new_from_file cf::object::thawer $self->{load_path};
2030 $f->skip_block;
1545 $self->_load_objects ($self->{load_path}, 1) 2031 $self->_load_objects ($f)
1546 or return; 2032 or return;
1547 2033
1548 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2034 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1549 if delete $self->{load_original}; 2035 if delete $self->{load_original};
1550 2036
1551 if (my $uniq = $self->uniq_path) { 2037 if (my $uniq = $self->uniq_path) {
1552 utf8::encode $uniq; 2038 utf8::encode $uniq;
1553 if (aio_open $uniq, O_RDONLY, 0) { 2039 unless (aio_stat $uniq) {
2040 if (my $f = new_from_file cf::object::thawer $uniq) {
1554 $self->clear_unique_items; 2041 $self->clear_unique_items;
1555 $self->_load_objects ($uniq, 0); 2042 $self->_load_objects ($f);
2043 $f->resolve_delayed_derefs;
2044 }
1556 } 2045 }
1557 } 2046 }
1558 2047
1559 Coro::cede; 2048 $f->resolve_delayed_derefs;
2049
2050 cf::cede_to_tick;
1560 # now do the right thing for maps 2051 # now do the right thing for maps
1561 $self->link_multipart_objects; 2052 $self->link_multipart_objects;
1562 $self->difficulty ($self->estimate_difficulty) 2053 $self->difficulty ($self->estimate_difficulty)
1563 unless $self->difficulty; 2054 unless $self->difficulty;
1564 Coro::cede; 2055 cf::cede_to_tick;
1565 2056
1566 unless ($self->{deny_activate}) { 2057 unless ($self->{deny_activate}) {
1567 $self->decay_objects; 2058 $self->decay_objects;
1568 $self->fix_auto_apply; 2059 $self->fix_auto_apply;
1569 $self->update_buttons; 2060 $self->update_buttons;
1570 Coro::cede; 2061 cf::cede_to_tick;
1571 $self->set_darkness_map; 2062 $self->set_darkness_map;
1572 Coro::cede; 2063 cf::cede_to_tick;
1573 $self->activate; 2064 $self->activate;
1574 } 2065 }
2066
2067 $self->{last_save} = $cf::RUNTIME;
2068 $self->last_access ($cf::RUNTIME);
1575 2069
1576 $self->in_memory (cf::MAP_IN_MEMORY); 2070 $self->in_memory (cf::MAP_IN_MEMORY);
1577 } 2071 }
1578 2072
1579 $self->post_load; 2073 $self->post_load;
… …
1583 my ($self, $ob) = @_; 2077 my ($self, $ob) = @_;
1584 2078
1585 return find "~" . $ob->name . "/" . $self->{path} 2079 return find "~" . $ob->name . "/" . $self->{path}
1586 if $self->per_player; 2080 if $self->per_player;
1587 2081
2082# return find "?party/" . $ob->name . "/" . $self->{path}
2083# if $self->per_party;
2084
1588 $self 2085 $self
1589} 2086}
1590 2087
1591# find and load all maps in the 3x3 area around a map 2088# find and load all maps in the 3x3 area around a map
1592sub load_diag { 2089sub load_neighbours {
1593 my ($map) = @_; 2090 my ($map) = @_;
1594 2091
1595 my @diag; # diagonal neighbours 2092 my @neigh; # diagonal neighbours
1596 2093
1597 for (0 .. 3) { 2094 for (0 .. 3) {
1598 my $neigh = $map->tile_path ($_) 2095 my $neigh = $map->tile_path ($_)
1599 or next; 2096 or next;
1600 $neigh = find $neigh, $map 2097 $neigh = find $neigh, $map
1601 or next; 2098 or next;
1602 $neigh->load; 2099 $neigh->load;
1603 2100
2101 push @neigh,
1604 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2102 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1605 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2103 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1606 } 2104 }
1607 2105
1608 for (@diag) { 2106 for (grep defined $_->[0], @neigh) {
2107 my ($path, $origin) = @$_;
1609 my $neigh = find @$_ 2108 my $neigh = find $path, $origin
1610 or next; 2109 or next;
1611 $neigh->load; 2110 $neigh->load;
1612 } 2111 }
1613} 2112}
1614 2113
… …
1619} 2118}
1620 2119
1621sub do_load_sync { 2120sub do_load_sync {
1622 my ($map) = @_; 2121 my ($map) = @_;
1623 2122
2123 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2124 if $Coro::current == $Coro::main;
2125
1624 cf::sync_job { $map->load }; 2126 cf::sync_job { $map->load };
1625} 2127}
1626 2128
1627our %MAP_PREFETCH; 2129our %MAP_PREFETCH;
1628our $MAP_PREFETCHER = undef; 2130our $MAP_PREFETCHER = undef;
1629 2131
1630sub find_async { 2132sub find_async {
1631 my ($path, $origin) = @_; 2133 my ($path, $origin, $load) = @_;
1632 2134
1633 $path = normalise $path, $origin && $origin->{path}; 2135 $path = normalise $path, $origin && $origin->{path};
1634 2136
1635 if (my $map = $cf::MAP{$path}) { 2137 if (my $map = $cf::MAP{$path}) {
1636 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2138 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1637 } 2139 }
1638 2140
1639 undef $MAP_PREFETCH{$path}; 2141 $MAP_PREFETCH{$path} |= $load;
2142
1640 $MAP_PREFETCHER ||= cf::async { 2143 $MAP_PREFETCHER ||= cf::async {
2144 $Coro::current->{desc} = "map prefetcher";
2145
1641 while (%MAP_PREFETCH) { 2146 while (%MAP_PREFETCH) {
1642 for my $path (keys %MAP_PREFETCH) { 2147 while (my ($k, $v) = each %MAP_PREFETCH) {
1643 my $map = find $path 2148 if (my $map = find $k) {
1644 or next;
1645 $map->load; 2149 $map->load if $v;
2150 }
1646 2151
1647 delete $MAP_PREFETCH{$path}; 2152 delete $MAP_PREFETCH{$k};
1648 } 2153 }
1649 } 2154 }
1650 undef $MAP_PREFETCHER; 2155 undef $MAP_PREFETCHER;
1651 }; 2156 };
1652 $MAP_PREFETCHER->prio (6); 2157 $MAP_PREFETCHER->prio (6);
… …
1655} 2160}
1656 2161
1657sub save { 2162sub save {
1658 my ($self) = @_; 2163 my ($self) = @_;
1659 2164
1660 my $lock = cf::lock_acquire "map_data:" . $self->path; 2165 my $lock = cf::lock_acquire "map_data:$self->{path}";
1661 2166
1662 $self->{last_save} = $cf::RUNTIME; 2167 $self->{last_save} = $cf::RUNTIME;
1663 2168
1664 return unless $self->dirty; 2169 return unless $self->dirty;
1665 2170
… …
1671 return if $self->{deny_save}; 2176 return if $self->{deny_save};
1672 2177
1673 local $self->{last_access} = $self->last_access;#d# 2178 local $self->{last_access} = $self->last_access;#d#
1674 2179
1675 cf::async { 2180 cf::async {
2181 $Coro::current->{desc} = "map player save";
1676 $_->contr->save for $self->players; 2182 $_->contr->save for $self->players;
1677 }; 2183 };
1678 2184
1679 if ($uniq) { 2185 if ($uniq) {
1680 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2186 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1688 my ($self) = @_; 2194 my ($self) = @_;
1689 2195
1690 # save first because save cedes 2196 # save first because save cedes
1691 $self->save; 2197 $self->save;
1692 2198
1693 my $lock = cf::lock_acquire "map_data:" . $self->path; 2199 my $lock = cf::lock_acquire "map_data:$self->{path}";
1694 2200
1695 return if $self->players; 2201 return if $self->players;
1696 return if $self->in_memory != cf::MAP_IN_MEMORY; 2202 return if $self->in_memory != cf::MAP_IN_MEMORY;
1697 return if $self->{deny_save}; 2203 return if $self->{deny_save};
1698 2204
2205 $self->in_memory (cf::MAP_SWAPPED);
2206
2207 $self->deactivate;
2208 $_->clear_links_to ($self) for values %cf::MAP;
1699 $self->clear; 2209 $self->clear;
1700 $self->in_memory (cf::MAP_SWAPPED);
1701} 2210}
1702 2211
1703sub reset_at { 2212sub reset_at {
1704 my ($self) = @_; 2213 my ($self) = @_;
1705 2214
1706 # TODO: safety, remove and allow resettable per-player maps 2215 # TODO: safety, remove and allow resettable per-player maps
1707 return 1e99 if $self->isa ("ext::map_per_player");#d#
1708 return 1e99 if $self->{deny_reset}; 2216 return 1e99 if $self->{deny_reset};
1709 2217
1710 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2218 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1711 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2219 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1712 2220
… …
1723 my ($self) = @_; 2231 my ($self) = @_;
1724 2232
1725 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2233 my $lock = cf::lock_acquire "map_data:$self->{path}";
1726 2234
1727 return if $self->players; 2235 return if $self->players;
1728 return if $self->isa ("ext::map_per_player");#d#
1729 2236
1730 warn "resetting map ", $self->path;#d# 2237 warn "resetting map ", $self->path;
1731 2238
1732 $self->in_memory (cf::MAP_SWAPPED); 2239 $self->in_memory (cf::MAP_SWAPPED);
1733 2240
1734 # need to save uniques path 2241 # need to save uniques path
1735 unless ($self->{deny_save}) { 2242 unless ($self->{deny_save}) {
… …
1739 if $uniq; 2246 if $uniq;
1740 } 2247 }
1741 2248
1742 delete $cf::MAP{$self->path}; 2249 delete $cf::MAP{$self->path};
1743 2250
2251 $self->deactivate;
2252 $_->clear_links_to ($self) for values %cf::MAP;
1744 $self->clear; 2253 $self->clear;
1745
1746 $_->clear_links_to ($self) for values %cf::MAP;
1747 2254
1748 $self->unlink_save; 2255 $self->unlink_save;
1749 $self->destroy; 2256 $self->destroy;
1750} 2257}
1751 2258
1752my $nuke_counter = "aaaa"; 2259my $nuke_counter = "aaaa";
1753 2260
1754sub nuke { 2261sub nuke {
1755 my ($self) = @_; 2262 my ($self) = @_;
1756 2263
2264 {
2265 my $lock = cf::lock_acquire "map_data:$self->{path}";
2266
1757 delete $cf::MAP{$self->path}; 2267 delete $cf::MAP{$self->path};
1758 2268
1759 $self->unlink_save; 2269 $self->unlink_save;
1760 2270
1761 bless $self, "cf::map"; 2271 bless $self, "cf::map";
1762 delete $self->{deny_reset}; 2272 delete $self->{deny_reset};
1763 $self->{deny_save} = 1; 2273 $self->{deny_save} = 1;
1764 $self->reset_timeout (1); 2274 $self->reset_timeout (1);
1765 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2275 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1766 2276
1767 $cf::MAP{$self->path} = $self; 2277 $cf::MAP{$self->path} = $self;
2278 }
1768 2279
1769 $self->reset; # polite request, might not happen 2280 $self->reset; # polite request, might not happen
2281}
2282
2283=item $maps = cf::map::tmp_maps
2284
2285Returns an arrayref with all map paths of currently instantiated and saved
2286maps. May block.
2287
2288=cut
2289
2290sub tmp_maps() {
2291 [
2292 map {
2293 utf8::decode $_;
2294 /\.map$/
2295 ? normalise $_
2296 : ()
2297 } @{ aio_readdir $TMPDIR or [] }
2298 ]
2299}
2300
2301=item $maps = cf::map::random_maps
2302
2303Returns an arrayref with all map paths of currently instantiated and saved
2304random maps. May block.
2305
2306=cut
2307
2308sub random_maps() {
2309 [
2310 map {
2311 utf8::decode $_;
2312 /\.map$/
2313 ? normalise "?random/$_"
2314 : ()
2315 } @{ aio_readdir $RANDOMDIR or [] }
2316 ]
1770} 2317}
1771 2318
1772=item cf::map::unique_maps 2319=item cf::map::unique_maps
1773 2320
1774Returns an arrayref of paths of all shared maps that have 2321Returns an arrayref of paths of all shared maps that have
1775instantiated unique items. May block. 2322instantiated unique items. May block.
1776 2323
1777=cut 2324=cut
1778 2325
1779sub unique_maps() { 2326sub unique_maps() {
1780 my $files = aio_readdir $UNIQUEDIR 2327 [
1781 or return; 2328 map {
1782
1783 my @paths;
1784
1785 for (@$files) {
1786 utf8::decode $_; 2329 utf8::decode $_;
1787 next if /\.pst$/; 2330 /\.map$/
1788 next unless /^$PATH_SEP/o; 2331 ? normalise $_
1789 2332 : ()
1790 push @paths, cf::map::normalise $_; 2333 } @{ aio_readdir $UNIQUEDIR or [] }
1791 } 2334 ]
1792
1793 \@paths
1794} 2335}
1795 2336
1796package cf; 2337package cf;
1797 2338
1798=back 2339=back
… …
1816 map { $_, inv_recursive_ $_->inv } @_ 2357 map { $_, inv_recursive_ $_->inv } @_
1817} 2358}
1818 2359
1819sub inv_recursive { 2360sub inv_recursive {
1820 inv_recursive_ inv $_[0] 2361 inv_recursive_ inv $_[0]
2362}
2363
2364=item $ref = $ob->ref
2365
2366creates and returns a persistent reference to an objetc that can be stored as a string.
2367
2368=item $ob = cf::object::deref ($refstring)
2369
2370returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2371even if the object actually exists. May block.
2372
2373=cut
2374
2375sub deref {
2376 my ($ref) = @_;
2377
2378 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2379 my ($uuid, $name) = ($1, $2);
2380 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2381 or return;
2382 $pl->ob->uuid eq $uuid
2383 or return;
2384
2385 $pl->ob
2386 } else {
2387 warn "$ref: cannot resolve object reference\n";
2388 undef
2389 }
1821} 2390}
1822 2391
1823package cf; 2392package cf;
1824 2393
1825=back 2394=back
… …
1844 2413
1845 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2414 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1846 2415
1847 if ($self->{record_replies}) { 2416 if ($self->{record_replies}) {
1848 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2417 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2418
1849 } else { 2419 } else {
2420 my $pl = $self->contr;
2421
2422 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2423 my $dialog = $pl->{npc_dialog};
2424 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2425
2426 } else {
1850 $msg = $npc->name . " says: $msg" if $npc; 2427 $msg = $npc->name . " says: $msg" if $npc;
1851 $self->message ($msg, $flags); 2428 $self->message ($msg, $flags);
2429 }
1852 } 2430 }
2431}
2432
2433=item $object->send_msg ($channel, $msg, $color, [extra...])
2434
2435=cut
2436
2437sub cf::object::send_msg {
2438 my $pl = shift->contr
2439 or return;
2440 $pl->send_msg (@_);
1853} 2441}
1854 2442
1855=item $player_object->may ("access") 2443=item $player_object->may ("access")
1856 2444
1857Returns wether the given player is authorized to access resource "access" 2445Returns wether the given player is authorized to access resource "access"
… …
1904 $self->deactivate_recursive; 2492 $self->deactivate_recursive;
1905 2493
1906 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2494 return if UNIVERSAL::isa $self->map, "ext::map_link";
1907 2495
1908 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2496 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1909 if $self->map; 2497 if $self->map && $self->map->{path} ne "{link}";
1910 2498
1911 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2499 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1912} 2500}
1913 2501
1914sub cf::object::player::leave_link { 2502sub cf::object::player::leave_link {
1915 my ($self, $map, $x, $y) = @_; 2503 my ($self, $map, $x, $y) = @_;
2504
2505 return unless $self->contr->active;
1916 2506
1917 my $link_pos = delete $self->{_link_pos}; 2507 my $link_pos = delete $self->{_link_pos};
1918 2508
1919 unless ($map) { 2509 unless ($map) {
1920 # restore original map position 2510 # restore original map position
… …
1934 # use -1 or undef as default coordinates, not 0, 0 2524 # use -1 or undef as default coordinates, not 0, 0
1935 ($x, $y) = ($map->enter_x, $map->enter_y) 2525 ($x, $y) = ($map->enter_x, $map->enter_y)
1936 if $x <=0 && $y <= 0; 2526 if $x <=0 && $y <= 0;
1937 2527
1938 $map->load; 2528 $map->load;
1939 $map->load_diag; 2529 $map->load_neighbours;
1940 2530
1941 return unless $self->contr->active; 2531 return unless $self->contr->active;
1942 $self->activate_recursive; 2532 $self->activate_recursive;
1943 2533
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2534 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1945 $self->enter_map ($map, $x, $y); 2535 $self->enter_map ($map, $x, $y);
1946} 2536}
1947 2537
1948cf::player->attach (
1949 on_logout => sub {
1950 my ($pl) = @_;
1951
1952 # abort map switching before logout
1953 if ($pl->ob->{_link_pos}) {
1954 cf::sync_job {
1955 $pl->ob->leave_link
1956 };
1957 }
1958 },
1959 on_login => sub {
1960 my ($pl) = @_;
1961
1962 # try to abort aborted map switching on player login :)
1963 # should happen only on crashes
1964 if ($pl->ob->{_link_pos}) {
1965 $pl->ob->enter_link;
1966 (async {
1967 $pl->ob->reply (undef,
1968 "There was an internal problem at your last logout, "
1969 . "the server will try to bring you to your intended destination in a second.",
1970 cf::NDI_RED);
1971 # we need this sleep as the login has a concurrent enter_exit running
1972 # and this sleep increases chances of the player not ending up in scorn
1973 Coro::Timer::sleep 1;
1974 $pl->ob->leave_link;
1975 })->prio (2);
1976 }
1977 },
1978);
1979
1980=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2538=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1981 2539
1982Moves the player to the given map-path and coordinates by first freezing 2540Moves the player to the given map-path and coordinates by first freezing
1983her, loading and preparing them map, calling the provided $check callback 2541her, loading and preparing them map, calling the provided $check callback
1984that has to return the map if sucecssful, and then unfreezes the player on 2542that has to return the map if sucecssful, and then unfreezes the player on
1985the new (success) or old (failed) map position. 2543the new (success) or old (failed) map position. In either case, $done will
2544be called at the end of this process.
1986 2545
1987=cut 2546=cut
2547
2548our $GOTOGEN;
1988 2549
1989sub cf::object::player::goto { 2550sub cf::object::player::goto {
1990 my ($self, $path, $x, $y, $check) = @_; 2551 my ($self, $path, $x, $y, $check, $done) = @_;
2552
2553 # do generation counting so two concurrent goto's will be executed in-order
2554 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1991 2555
1992 $self->enter_link; 2556 $self->enter_link;
1993 2557
1994 (async { 2558 (async {
2559 $Coro::current->{desc} = "player::goto $path $x $y";
2560
2561 # *tag paths override both path and x|y
2562 if ($path =~ /^\*(.*)$/) {
2563 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2564 my $ob = $obs[rand @obs];
2565
2566 # see if we actually can go there
2567 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2568 $ob = $obs[rand @obs];
2569 } else {
2570 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2571 }
2572 # else put us there anyways for now #d#
2573
2574 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2575 } else {
2576 ($path, $x, $y) = (undef, undef, undef);
2577 }
2578 }
2579
1995 my $map = eval { 2580 my $map = eval {
1996 my $map = cf::map::find $path; 2581 my $map = defined $path ? cf::map::find $path : undef;
1997 2582
1998 if ($map) { 2583 if ($map) {
1999 $map = $map->customise_for ($self); 2584 $map = $map->customise_for ($self);
2000 $map = $check->($map) if $check && $map; 2585 $map = $check->($map) if $check && $map;
2001 } else { 2586 } else {
2002 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2587 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2003 } 2588 }
2004 2589
2005 $map 2590 $map
2006 }; 2591 };
2007 2592
2008 if ($@) { 2593 if ($@) {
2009 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED); 2594 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2010 LOG llevError | logBacktrace, Carp::longmess $@; 2595 LOG llevError | logBacktrace, Carp::longmess $@;
2011 } 2596 }
2012 2597
2598 if ($gen == $self->{_goto_generation}) {
2599 delete $self->{_goto_generation};
2013 $self->leave_link ($map, $x, $y); 2600 $self->leave_link ($map, $x, $y);
2601 }
2602
2603 $done->() if $done;
2014 })->prio (1); 2604 })->prio (1);
2015} 2605}
2016 2606
2017=item $player_object->enter_exit ($exit_object) 2607=item $player_object->enter_exit ($exit_object)
2018 2608
… …
2055 $rmp->{origin_y} = $exit->y; 2645 $rmp->{origin_y} = $exit->y;
2056 } 2646 }
2057 2647
2058 $rmp->{random_seed} ||= $exit->random_seed; 2648 $rmp->{random_seed} ||= $exit->random_seed;
2059 2649
2060 my $data = cf::to_json $rmp; 2650 my $data = cf::encode_json $rmp;
2061 my $md5 = Digest::MD5::md5_hex $data; 2651 my $md5 = Digest::MD5::md5_hex $data;
2062 my $meta = "$RANDOMDIR/$md5.meta"; 2652 my $meta = "$RANDOMDIR/$md5.meta";
2063 2653
2064 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2654 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2065 aio_write $fh, 0, (length $data), $data, 0; 2655 aio_write $fh, 0, (length $data), $data, 0;
… …
2087 my $hp = $exit->stats->hp; 2677 my $hp = $exit->stats->hp;
2088 my $sp = $exit->stats->sp; 2678 my $sp = $exit->stats->sp;
2089 2679
2090 $self->enter_link; 2680 $self->enter_link;
2091 2681
2682 # if exit is damned, update players death & WoR home-position
2683 $self->contr->savebed ($slaying, $hp, $sp)
2684 if $exit->flag (FLAG_DAMNED);
2685
2092 (async { 2686 (async {
2687 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2688
2093 $self->deactivate_recursive; # just to be sure 2689 $self->deactivate_recursive; # just to be sure
2094 unless (eval { 2690 unless (eval {
2095 $self->goto ($slaying, $hp, $sp); 2691 $self->goto ($slaying, $hp, $sp);
2096 2692
2097 1; 2693 1;
… …
2123 2719
2124 utf8::encode $text; 2720 utf8::encode $text;
2125 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2721 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2126} 2722}
2127 2723
2724=item $client->send_msg ($channel, $msg, $color, [extra...])
2725
2726Send a drawinfo or msg packet to the client, formatting the msg for the
2727client if neccessary. C<$type> should be a string identifying the type of
2728the message, with C<log> being the default. If C<$color> is negative, suppress
2729the message unless the client supports the msg packet.
2730
2731=cut
2732
2733# non-persistent channels (usually the info channel)
2734our %CHANNEL = (
2735 "c/identify" => {
2736 id => "infobox",
2737 title => "Identify",
2738 reply => undef,
2739 tooltip => "Items recently identified",
2740 },
2741 "c/examine" => {
2742 id => "infobox",
2743 title => "Examine",
2744 reply => undef,
2745 tooltip => "Signs and other items you examined",
2746 },
2747 "c/book" => {
2748 id => "infobox",
2749 title => "Book",
2750 reply => undef,
2751 tooltip => "The contents of a note or book",
2752 },
2753 "c/lookat" => {
2754 id => "infobox",
2755 title => "Look",
2756 reply => undef,
2757 tooltip => "What you saw there",
2758 },
2759 "c/who" => {
2760 id => "infobox",
2761 title => "Players",
2762 reply => undef,
2763 tooltip => "Shows players who are currently online",
2764 },
2765 "c/body" => {
2766 id => "infobox",
2767 title => "Body Parts",
2768 reply => undef,
2769 tooltip => "Shows which body parts you posess and are available",
2770 },
2771 "c/uptime" => {
2772 id => "infobox",
2773 title => "Uptime",
2774 reply => undef,
2775 tooltip => "How long the server has been running since last restart",
2776 },
2777 "c/mapinfo" => {
2778 id => "infobox",
2779 title => "Map Info",
2780 reply => undef,
2781 tooltip => "Information related to the maps",
2782 },
2783);
2784
2785sub cf::client::send_msg {
2786 my ($self, $channel, $msg, $color, @extra) = @_;
2787
2788 $msg = $self->pl->expand_cfpod ($msg);
2789
2790 $color &= cf::NDI_CLIENT_MASK; # just in case...
2791
2792 # check predefined channels, for the benefit of C
2793 if ($CHANNEL{$channel}) {
2794 $channel = $CHANNEL{$channel};
2795
2796 $self->ext_msg (channel_info => $channel)
2797 if $self->can_msg;
2798
2799 $channel = $channel->{id};
2800
2801 } elsif (ref $channel) {
2802 # send meta info to client, if not yet sent
2803 unless (exists $self->{channel}{$channel->{id}}) {
2804 $self->{channel}{$channel->{id}} = $channel;
2805 $self->ext_msg (channel_info => $channel)
2806 if $self->can_msg;
2807 }
2808
2809 $channel = $channel->{id};
2810 }
2811
2812 return unless @extra || length $msg;
2813
2814 if ($self->can_msg) {
2815 # default colour, mask it out
2816 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2817 if $color & cf::NDI_DEF;
2818
2819 $self->send_packet ("msg " . $self->{json_coder}->encode (
2820 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2821 } else {
2822 if ($color >= 0) {
2823 # replace some tags by gcfclient-compatible ones
2824 for ($msg) {
2825 1 while
2826 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2827 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2828 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2829 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2830 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2831 }
2832
2833 $color &= cf::NDI_COLOR_MASK;
2834
2835 utf8::encode $msg;
2836
2837 if (0 && $msg =~ /\[/) {
2838 # COMMAND/INFO
2839 $self->send_packet ("drawextinfo $color 10 8 $msg")
2840 } else {
2841 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2842 $self->send_packet ("drawinfo $color $msg")
2843 }
2844 }
2845 }
2846}
2847
2128=item $client->ext_event ($type, %msg) 2848=item $client->ext_msg ($type, @msg)
2129 2849
2130Sends an exti event to the client. 2850Sends an ext event to the client.
2131 2851
2132=cut 2852=cut
2133 2853
2134sub cf::client::ext_event($$%) { 2854sub cf::client::ext_msg($$@) {
2135 my ($self, $type, %msg) = @_; 2855 my ($self, $type, @msg) = @_;
2136 2856
2857 if ($self->extcmd == 2) {
2858 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2859 } elsif ($self->extcmd == 1) { # TODO: remove
2137 $msg{msgtype} = "event_$type"; 2860 push @msg, msgtype => "event_$type";
2138 $self->send_packet ("ext " . cf::to_json \%msg); 2861 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2862 }
2863}
2864
2865=item $client->ext_reply ($msgid, @msg)
2866
2867Sends an ext reply to the client.
2868
2869=cut
2870
2871sub cf::client::ext_reply($$@) {
2872 my ($self, $id, @msg) = @_;
2873
2874 if ($self->extcmd == 2) {
2875 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2876 } elsif ($self->extcmd == 1) {
2877 #TODO: version 1, remove
2878 unshift @msg, msgtype => "reply", msgid => $id;
2879 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2880 }
2139} 2881}
2140 2882
2141=item $success = $client->query ($flags, "text", \&cb) 2883=item $success = $client->query ($flags, "text", \&cb)
2142 2884
2143Queues a query to the client, calling the given callback with 2885Queues a query to the client, calling the given callback with
2144the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2886the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2145C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2887C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2146 2888
2147Queries can fail, so check the return code. Or don't, as queries will become 2889Queries can fail, so check the return code. Or don't, as queries will
2148reliable at some point in the future. 2890become reliable at some point in the future.
2149 2891
2150=cut 2892=cut
2151 2893
2152sub cf::client::query { 2894sub cf::client::query {
2153 my ($self, $flags, $text, $cb) = @_; 2895 my ($self, $flags, $text, $cb) = @_;
… …
2161 utf8::encode $text; 2903 utf8::encode $text;
2162 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2904 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2163 2905
2164 $self->send_packet ($self->{query_queue}[0][0]) 2906 $self->send_packet ($self->{query_queue}[0][0])
2165 if @{ $self->{query_queue} } == 1; 2907 if @{ $self->{query_queue} } == 1;
2908
2909 1
2166} 2910}
2167 2911
2168cf::client->attach ( 2912cf::client->attach (
2913 on_connect => sub {
2914 my ($ns) = @_;
2915
2916 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2917 },
2169 on_reply => sub { 2918 on_reply => sub {
2170 my ($ns, $msg) = @_; 2919 my ($ns, $msg) = @_;
2171 2920
2172 # this weird shuffling is so that direct followup queries 2921 # this weird shuffling is so that direct followup queries
2173 # get handled first 2922 # get handled first
… …
2185 } else { 2934 } else {
2186 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2935 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2187 } 2936 }
2188 } 2937 }
2189 }, 2938 },
2939 on_exticmd => sub {
2940 my ($ns, $buf) = @_;
2941
2942 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2943
2944 if (ref $msg) {
2945 my ($type, $reply, @payload) =
2946 "ARRAY" eq ref $msg
2947 ? @$msg
2948 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2949
2950 my @reply;
2951
2952 if (my $cb = $EXTICMD{$type}) {
2953 @reply = $cb->($ns, @payload);
2954 }
2955
2956 $ns->ext_reply ($reply, @reply)
2957 if $reply;
2958
2959 } else {
2960 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2961 }
2962
2963 cf::override;
2964 },
2190); 2965);
2191 2966
2192=item $client->async (\&cb) 2967=item $client->async (\&cb)
2193 2968
2194Create a new coroutine, running the specified callback. The coroutine will 2969Create a new coroutine, running the specified callback. The coroutine will
… …
2235our $safe = new Safe "safe"; 3010our $safe = new Safe "safe";
2236our $safe_hole = new Safe::Hole; 3011our $safe_hole = new Safe::Hole;
2237 3012
2238$SIG{FPE} = 'IGNORE'; 3013$SIG{FPE} = 'IGNORE';
2239 3014
2240$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3015$safe->permit_only (Opcode::opset qw(
3016 :base_core :base_mem :base_orig :base_math
3017 grepstart grepwhile mapstart mapwhile
3018 sort time
3019));
2241 3020
2242# here we export the classes and methods available to script code 3021# here we export the classes and methods available to script code
2243 3022
2244=pod 3023=pod
2245 3024
2246The following functions and methods are available within a safe environment: 3025The following functions and methods are available within a safe environment:
2247 3026
2248 cf::object contr pay_amount pay_player map 3027 cf::object
3028 contr pay_amount pay_player map x y force_find force_add destroy
3029 insert remove name archname title slaying race decrease_ob_nr
3030
2249 cf::object::player player 3031 cf::object::player
2250 cf::player peaceful 3032 player
2251 cf::map trigger 3033
3034 cf::player
3035 peaceful
3036
3037 cf::map
3038 trigger
2252 3039
2253=cut 3040=cut
2254 3041
2255for ( 3042for (
2256 ["cf::object" => qw(contr pay_amount pay_player map)], 3043 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3044 insert remove inv name archname title slaying race
3045 decrease_ob_nr destroy)],
2257 ["cf::object::player" => qw(player)], 3046 ["cf::object::player" => qw(player)],
2258 ["cf::player" => qw(peaceful)], 3047 ["cf::player" => qw(peaceful)],
2259 ["cf::map" => qw(trigger)], 3048 ["cf::map" => qw(trigger)],
2260) { 3049) {
2261 no strict 'refs'; 3050 no strict 'refs';
… …
2332=back 3121=back
2333 3122
2334=cut 3123=cut
2335 3124
2336############################################################################# 3125#############################################################################
2337
2338=head2 EXTENSION DATABASE SUPPORT
2339
2340Crossfire maintains a very simple database for extension use. It can
2341currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2342convert to/from binary).
2343
2344The parameter C<$family> should best start with the name of the extension
2345using it, it should be unique.
2346
2347=over 4
2348
2349=item $value = cf::db_get $family => $key
2350
2351Returns a single value from the database.
2352
2353=item cf::db_put $family => $key => $value
2354
2355Stores the given C<$value> in the family.
2356
2357=cut
2358
2359our $DB;
2360
2361sub db_init {
2362 unless ($DB) {
2363 $DB = BDB::db_create $DB_ENV;
2364
2365 cf::sync_job {
2366 eval {
2367 $DB->set_flags (BDB::CHKSUM);
2368
2369 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2370 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2371 cf::cleanup "db_open(db): $!" if $!;
2372 };
2373 cf::cleanup "db_open(db): $@" if $@;
2374 };
2375 }
2376}
2377
2378sub db_get($$) {
2379 my $key = "$_[0]/$_[1]";
2380
2381 cf::sync_job {
2382 BDB::db_get $DB, undef, $key, my $data;
2383
2384 $! ? ()
2385 : $data
2386 }
2387}
2388
2389sub db_put($$$) {
2390 BDB::dbreq_pri 4;
2391 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2392}
2393
2394=item cf::cache $id => [$paths...], $processversion => $process
2395
2396Generic caching function that returns the value of the resource $id,
2397caching and regenerating as required.
2398
2399This function can block.
2400
2401=cut
2402
2403sub cache {
2404 my ($id, $src, $processversion, $process) = @_;
2405
2406 my $meta =
2407 join "\x00",
2408 $processversion,
2409 map {
2410 aio_stat $_
2411 and Carp::croak "$_: $!";
2412
2413 ($_, (stat _)[7,9])
2414 } @$src;
2415
2416 my $dbmeta = db_get cache => "$id/meta";
2417 if ($dbmeta ne $meta) {
2418 # changed, we may need to process
2419
2420 my @data;
2421 my $md5;
2422
2423 for (0 .. $#$src) {
2424 0 <= aio_load $src->[$_], $data[$_]
2425 or Carp::croak "$src->[$_]: $!";
2426 }
2427
2428 # if processing is expensive, check
2429 # checksum first
2430 if (1) {
2431 $md5 =
2432 join "\x00",
2433 $processversion,
2434 map {
2435 Coro::cede;
2436 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2437 } 0.. $#$src;
2438
2439
2440 my $dbmd5 = db_get cache => "$id/md5";
2441 if ($dbmd5 eq $md5) {
2442 db_put cache => "$id/meta", $meta;
2443
2444 return db_get cache => "$id/data";
2445 }
2446 }
2447
2448 my $t1 = Time::HiRes::time;
2449 my $data = $process->(\@data);
2450 my $t2 = Time::HiRes::time;
2451
2452 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2453
2454 db_put cache => "$id/data", $data;
2455 db_put cache => "$id/md5" , $md5;
2456 db_put cache => "$id/meta", $meta;
2457
2458 return $data;
2459 }
2460
2461 db_get cache => "$id/data"
2462}
2463
2464=item fork_call { }, $args
2465
2466Executes the given code block with the given arguments in a seperate
2467process, returning the results. Everything must be serialisable with
2468Coro::Storable. May, of course, block. Note that the executed sub may
2469never block itself or use any form of Event handling.
2470
2471=cut
2472
2473sub fork_call(&@) {
2474 my ($cb, @args) = @_;
2475
2476# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2477# or die "socketpair: $!";
2478 pipe my $fh1, my $fh2
2479 or die "pipe: $!";
2480
2481 if (my $pid = fork) {
2482 close $fh2;
2483
2484 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2485 $res = Coro::Storable::thaw $res;
2486
2487 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2488
2489 die $$res unless "ARRAY" eq ref $res;
2490
2491 return wantarray ? @$res : $res->[-1];
2492 } else {
2493 reset_signals;
2494 local $SIG{__WARN__};
2495 local $SIG{__DIE__};
2496 eval {
2497 close $fh1;
2498
2499 my @res = eval { $cb->(@args) };
2500 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2501 };
2502
2503 warn $@ if $@;
2504 _exit 0;
2505 }
2506}
2507
2508
2509
2510#############################################################################
2511# the server's init and main functions 3126# the server's init and main functions
2512 3127
2513sub load_facedata($) { 3128sub load_facedata($) {
2514 my ($path) = @_; 3129 my ($path) = @_;
3130
3131 # HACK to clear player env face cache, we need some signal framework
3132 # for this (global event?)
3133 %ext::player_env::MUSIC_FACE_CACHE = ();
3134
3135 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2515 3136
2516 warn "loading facedata from $path\n"; 3137 warn "loading facedata from $path\n";
2517 3138
2518 my $facedata; 3139 my $facedata;
2519 0 < aio_load $path, $facedata 3140 0 < aio_load $path, $facedata
… …
2522 $facedata = Coro::Storable::thaw $facedata; 3143 $facedata = Coro::Storable::thaw $facedata;
2523 3144
2524 $facedata->{version} == 2 3145 $facedata->{version} == 2
2525 or cf::cleanup "$path: version mismatch, cannot proceed."; 3146 or cf::cleanup "$path: version mismatch, cannot proceed.";
2526 3147
3148 # patch in the exptable
3149 $facedata->{resource}{"res/exp_table"} = {
3150 type => FT_RSRC,
3151 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3152 };
3153 cf::cede_to_tick;
3154
2527 { 3155 {
2528 my $faces = $facedata->{faceinfo}; 3156 my $faces = $facedata->{faceinfo};
2529 3157
2530 while (my ($face, $info) = each %$faces) { 3158 while (my ($face, $info) = each %$faces) {
2531 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3159 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3160
2532 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3161 cf::face::set_visibility $idx, $info->{visibility};
3162 cf::face::set_magicmap $idx, $info->{magicmap};
2533 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3163 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2534 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3164 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2535 Coro::cede; 3165
3166 cf::cede_to_tick;
2536 } 3167 }
2537 3168
2538 while (my ($face, $info) = each %$faces) { 3169 while (my ($face, $info) = each %$faces) {
2539 next unless $info->{smooth}; 3170 next unless $info->{smooth};
3171
2540 my $idx = cf::face::find $face 3172 my $idx = cf::face::find $face
2541 or next; 3173 or next;
3174
2542 if (my $smooth = cf::face::find $info->{smooth}) { 3175 if (my $smooth = cf::face::find $info->{smooth}) {
3176 cf::face::set_smooth $idx, $smooth;
2543 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3177 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2544 } else { 3178 } else {
2545 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3179 warn "smooth face '$info->{smooth}' not found for face '$face'";
2546 } 3180 }
2547 Coro::cede; 3181
3182 cf::cede_to_tick;
2548 } 3183 }
2549 } 3184 }
2550 3185
2551 { 3186 {
2552 my $anims = $facedata->{animinfo}; 3187 my $anims = $facedata->{animinfo};
2553 3188
2554 while (my ($anim, $info) = each %$anims) { 3189 while (my ($anim, $info) = each %$anims) {
2555 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3190 cf::anim::set $anim, $info->{frames}, $info->{facings};
2556 Coro::cede; 3191 cf::cede_to_tick;
2557 } 3192 }
2558 3193
2559 cf::anim::invalidate_all; # d'oh 3194 cf::anim::invalidate_all; # d'oh
2560 } 3195 }
2561 3196
3197 {
3198 # TODO: for gcfclient pleasure, we should give resources
3199 # that gcfclient doesn't grok a >10000 face index.
3200 my $res = $facedata->{resource};
3201
3202 while (my ($name, $info) = each %$res) {
3203 if (defined $info->{type}) {
3204 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3205 my $data;
3206
3207 if ($info->{type} & 1) {
3208 # prepend meta info
3209
3210 my $meta = $enc->encode ({
3211 name => $name,
3212 %{ $info->{meta} || {} },
3213 });
3214
3215 $data = pack "(w/a*)*", $meta, $info->{data};
3216 } else {
3217 $data = $info->{data};
3218 }
3219
3220 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3221 cf::face::set_type $idx, $info->{type};
3222 } else {
3223 $RESOURCE{$name} = $info;
3224 }
3225
3226 cf::cede_to_tick;
3227 }
3228 }
3229
3230 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3231
2562 1 3232 1
2563} 3233}
2564 3234
3235cf::global->attach (on_resource_update => sub {
3236 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3237 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3238
3239 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3240 my $sound = $soundconf->{compat}[$_]
3241 or next;
3242
3243 my $face = cf::face::find "sound/$sound->[1]";
3244 cf::sound::set $sound->[0] => $face;
3245 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3246 }
3247
3248 while (my ($k, $v) = each %{$soundconf->{event}}) {
3249 my $face = cf::face::find "sound/$v";
3250 cf::sound::set $k => $face;
3251 }
3252 }
3253});
3254
3255register_exticmd fx_want => sub {
3256 my ($ns, $want) = @_;
3257
3258 while (my ($k, $v) = each %$want) {
3259 $ns->fx_want ($k, $v);
3260 }
3261};
3262
2565sub reload_regions { 3263sub reload_regions {
3264 # HACK to clear player env face cache, we need some signal framework
3265 # for this (global event?)
3266 %ext::player_env::MUSIC_FACE_CACHE = ();
3267
2566 load_resource_file "$MAPDIR/regions" 3268 load_resource_file "$MAPDIR/regions"
2567 or die "unable to load regions file\n"; 3269 or die "unable to load regions file\n";
3270
3271 for (cf::region::list) {
3272 $_->{match} = qr/$_->{match}/
3273 if exists $_->{match};
3274 }
2568} 3275}
2569 3276
2570sub reload_facedata { 3277sub reload_facedata {
2571 load_facedata "$DATADIR/facedata" 3278 load_facedata "$DATADIR/facedata"
2572 or die "unable to load facedata\n"; 3279 or die "unable to load facedata\n";
2573} 3280}
2574 3281
2575sub reload_archetypes { 3282sub reload_archetypes {
2576 load_resource_file "$DATADIR/archetypes" 3283 load_resource_file "$DATADIR/archetypes"
2577 or die "unable to load archetypes\n"; 3284 or die "unable to load archetypes\n";
3285 #d# NEED to laod twice to resolve forward references
3286 # this really needs to be done in an extra post-pass
3287 # (which needs to be synchronous, so solve it differently)
3288 load_resource_file "$DATADIR/archetypes"
3289 or die "unable to load archetypes\n";
2578} 3290}
2579 3291
2580sub reload_treasures { 3292sub reload_treasures {
2581 load_resource_file "$DATADIR/treasures" 3293 load_resource_file "$DATADIR/treasures"
2582 or die "unable to load treasurelists\n"; 3294 or die "unable to load treasurelists\n";
… …
2585sub reload_resources { 3297sub reload_resources {
2586 warn "reloading resource files...\n"; 3298 warn "reloading resource files...\n";
2587 3299
2588 reload_regions; 3300 reload_regions;
2589 reload_facedata; 3301 reload_facedata;
3302 #reload_archetypes;#d#
2590 reload_archetypes; 3303 reload_archetypes;
2591 reload_treasures; 3304 reload_treasures;
2592 3305
2593 warn "finished reloading resource files\n"; 3306 warn "finished reloading resource files\n";
2594} 3307}
2595 3308
2596sub init { 3309sub init {
2597 reload_resources; 3310 reload_resources;
2598} 3311}
2599 3312
2600sub cfg_load { 3313sub reload_config {
2601 open my $fh, "<:utf8", "$CONFDIR/config" 3314 open my $fh, "<:utf8", "$CONFDIR/config"
2602 or return; 3315 or return;
2603 3316
2604 local $/; 3317 local $/;
2605 *CFG = YAML::Syck::Load <$fh>; 3318 *CFG = YAML::Syck::Load <$fh>;
… …
2621sub main { 3334sub main {
2622 # we must not ever block the main coroutine 3335 # we must not ever block the main coroutine
2623 local $Coro::idle = sub { 3336 local $Coro::idle = sub {
2624 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3337 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2625 (async { 3338 (async {
2626 Event::one_event; 3339 $Coro::current->{desc} = "IDLE BUG HANDLER";
3340 EV::loop EV::LOOP_ONESHOT;
2627 })->prio (Coro::PRIO_MAX); 3341 })->prio (Coro::PRIO_MAX);
2628 }; 3342 };
2629 3343
2630 cfg_load; 3344 reload_config;
2631 db_init; 3345 db_init;
2632 load_extensions; 3346 load_extensions;
2633 3347
2634 $TICK_WATCHER->start; 3348 $TICK_WATCHER->start;
3349 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
2635 Event::loop; 3350 EV::loop;
2636} 3351}
2637 3352
2638############################################################################# 3353#############################################################################
2639# initialisation and cleanup 3354# initialisation and cleanup
2640 3355
2641# install some emergency cleanup handlers 3356# install some emergency cleanup handlers
2642BEGIN { 3357BEGIN {
3358 our %SIGWATCHER = ();
2643 for my $signal (qw(INT HUP TERM)) { 3359 for my $signal (qw(INT HUP TERM)) {
2644 Event->signal ( 3360 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2645 reentrant => 0,
2646 data => WF_AUTOCANCEL,
2647 signal => $signal,
2648 prio => 0,
2649 cb => sub {
2650 cf::cleanup "SIG$signal"; 3361 cf::cleanup "SIG$signal";
2651 },
2652 ); 3362 };
3363 }
3364}
3365
3366sub write_runtime {
3367 my $runtime = "$LOCALDIR/runtime";
3368
3369 # first touch the runtime file to show we are still running:
3370 # the fsync below can take a very very long time.
3371
3372 IO::AIO::aio_utime $runtime, undef, undef;
3373
3374 my $guard = cf::lock_acquire "write_runtime";
3375
3376 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3377 or return;
3378
3379 my $value = $cf::RUNTIME + 90 + 10;
3380 # 10 is the runtime save interval, for a monotonic clock
3381 # 60 allows for the watchdog to kill the server.
3382
3383 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3384 and return;
3385
3386 # always fsync - this file is important
3387 aio_fsync $fh
3388 and return;
3389
3390 # touch it again to show we are up-to-date
3391 aio_utime $fh, undef, undef;
3392
3393 close $fh
3394 or return;
3395
3396 aio_rename "$runtime~", $runtime
3397 and return;
3398
3399 warn "runtime file written.\n";
3400
2653 } 3401 1
2654} 3402}
2655 3403
2656sub emergency_save() { 3404sub emergency_save() {
2657 my $freeze_guard = cf::freeze_mainloop; 3405 my $freeze_guard = cf::freeze_mainloop;
2658 3406
… …
2664 # and maps saved/destroyed asynchronously. 3412 # and maps saved/destroyed asynchronously.
2665 warn "begin emergency player save\n"; 3413 warn "begin emergency player save\n";
2666 for my $login (keys %cf::PLAYER) { 3414 for my $login (keys %cf::PLAYER) {
2667 my $pl = $cf::PLAYER{$login} or next; 3415 my $pl = $cf::PLAYER{$login} or next;
2668 $pl->valid or next; 3416 $pl->valid or next;
3417 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2669 $pl->save; 3418 $pl->save;
2670 } 3419 }
2671 warn "end emergency player save\n"; 3420 warn "end emergency player save\n";
2672 3421
2673 warn "begin emergency map save\n"; 3422 warn "begin emergency map save\n";
… …
2712 warn "syncing database to disk"; 3461 warn "syncing database to disk";
2713 BDB::db_env_txn_checkpoint $DB_ENV; 3462 BDB::db_env_txn_checkpoint $DB_ENV;
2714 3463
2715 # if anything goes wrong in here, we should simply crash as we already saved 3464 # if anything goes wrong in here, we should simply crash as we already saved
2716 3465
2717 warn "cancelling all WF_AUTOCANCEL watchers";
2718 for (Event::all_watchers) {
2719 $_->cancel if $_->data & WF_AUTOCANCEL;
2720 }
2721
2722 warn "flushing outstanding aio requests"; 3466 warn "flushing outstanding aio requests";
2723 for (;;) { 3467 for (;;) {
2724 BDB::flush; 3468 BDB::flush;
2725 IO::AIO::flush; 3469 IO::AIO::flush;
2726 Coro::cede; 3470 Coro::cede_notself;
2727 last unless IO::AIO::nreqs || BDB::nreqs; 3471 last unless IO::AIO::nreqs || BDB::nreqs;
2728 warn "iterate..."; 3472 warn "iterate...";
2729 } 3473 }
2730 3474
2731 ++$RELOAD; 3475 ++$RELOAD;
… …
2735 %EXT_CORO = (); 3479 %EXT_CORO = ();
2736 3480
2737 warn "removing commands"; 3481 warn "removing commands";
2738 %COMMAND = (); 3482 %COMMAND = ();
2739 3483
2740 warn "removing ext commands"; 3484 warn "removing ext/exti commands";
2741 %EXTCMD = (); 3485 %EXTCMD = ();
3486 %EXTICMD = ();
2742 3487
2743 warn "unloading/nuking all extensions"; 3488 warn "unloading/nuking all extensions";
2744 for my $pkg (@EXTS) { 3489 for my $pkg (@EXTS) {
2745 warn "... unloading $pkg"; 3490 warn "... unloading $pkg";
2746 3491
… …
2789 warn "reloading cf.pm"; 3534 warn "reloading cf.pm";
2790 require cf; 3535 require cf;
2791 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3536 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2792 3537
2793 warn "loading config and database again"; 3538 warn "loading config and database again";
2794 cf::cfg_load; 3539 cf::reload_config;
2795 3540
2796 warn "loading extensions"; 3541 warn "loading extensions";
2797 cf::load_extensions; 3542 cf::load_extensions;
2798 3543
2799 warn "reattaching attachments to objects/players"; 3544 warn "reattaching attachments to objects/players";
… …
2819 3564
2820sub reload_perl() { 3565sub reload_perl() {
2821 # doing reload synchronously and two reloads happen back-to-back, 3566 # doing reload synchronously and two reloads happen back-to-back,
2822 # coro crashes during coro_state_free->destroy here. 3567 # coro crashes during coro_state_free->destroy here.
2823 3568
2824 $RELOAD_WATCHER ||= Event->timer ( 3569 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
2825 reentrant => 0,
2826 after => 0,
2827 data => WF_AUTOCANCEL,
2828 cb => sub {
2829 do_reload_perl;
2830 undef $RELOAD_WATCHER; 3570 undef $RELOAD_WATCHER;
2831 }, 3571 do_reload_perl;
2832 ); 3572 };
2833} 3573}
2834 3574
2835register_command "reload" => sub { 3575register_command "reload" => sub {
2836 my ($who, $arg) = @_; 3576 my ($who, $arg) = @_;
2837 3577
2838 if ($who->flag (FLAG_WIZ)) { 3578 if ($who->flag (FLAG_WIZ)) {
2839 $who->message ("reloading server."); 3579 $who->message ("reloading server.");
3580 async {
3581 $Coro::current->{desc} = "perl_reload";
2840 async { reload_perl }; 3582 reload_perl;
3583 };
2841 } 3584 }
2842}; 3585};
2843 3586
2844unshift @INC, $LIBDIR; 3587unshift @INC, $LIBDIR;
2845 3588
… …
2864 my $signal = new Coro::Signal; 3607 my $signal = new Coro::Signal;
2865 push @WAIT_FOR_TICK_BEGIN, $signal; 3608 push @WAIT_FOR_TICK_BEGIN, $signal;
2866 $signal->wait; 3609 $signal->wait;
2867} 3610}
2868 3611
2869 my $min = 1e6;#d# 3612$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
2870 my $avg = 10;
2871$TICK_WATCHER = Event->timer (
2872 reentrant => 0,
2873 parked => 1,
2874 prio => 0,
2875 at => $NEXT_TICK || $TICK,
2876 data => WF_AUTOCANCEL,
2877 cb => sub {
2878 if ($Coro::current != $Coro::main) { 3613 if ($Coro::current != $Coro::main) {
2879 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3614 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2880 unless ++$bug_warning > 10; 3615 unless ++$bug_warning > 10;
2881 return; 3616 return;
2882 } 3617 }
2883 3618
2884 $NOW = $tick_start = Event::time; 3619 $NOW = $tick_start = EV::now;
2885 3620
2886 cf::server_tick; # one server iteration 3621 cf::server_tick; # one server iteration
2887 3622
2888 0 && sync_job {#d# 3623 $RUNTIME += $TICK;
2889 for(1..10) { 3624 $NEXT_TICK = $_[0]->at;
2890 my $t = Event::time;
2891 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2892 or die;
2893 3625
2894 $map->width (50); 3626 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2895 $map->height (50); 3627 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2896 $map->alloc; 3628 Coro::async_pool {
2897 $map->_load_objects ("/tmp/x.map", 1); 3629 $Coro::current->{desc} = "runtime saver";
2898 my $t = Event::time - $t; 3630 write_runtime
2899 3631 or warn "ERROR: unable to write runtime file: $!";
2900 #next unless $t < 0.0013;#d#
2901 if ($t < $min) {
2902 $min = $t;
2903 }
2904 $avg = $avg * 0.99 + $t * 0.01;
2905 }
2906 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2907 exit 0;
2908 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2909 }; 3632 };
3633 }
2910 3634
2911 $RUNTIME += $TICK;
2912 $NEXT_TICK += $TICK;
2913
2914 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2915 $NEXT_RUNTIME_WRITE = $NOW + 10;
2916 Coro::async_pool {
2917 write_runtime
2918 or warn "ERROR: unable to write runtime file: $!";
2919 };
2920 }
2921
2922# my $AFTER = Event::time;
2923# warn $AFTER - $NOW;#d#
2924
2925 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3635 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2926 $sig->send; 3636 $sig->send;
2927 } 3637 }
2928 while (my $sig = shift @WAIT_FOR_TICK) { 3638 while (my $sig = shift @WAIT_FOR_TICK) {
2929 $sig->send; 3639 $sig->send;
2930 } 3640 }
2931 3641
2932 $NOW = Event::time;
2933
2934 # if we are delayed by four ticks or more, skip them all
2935 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2936
2937 $TICK_WATCHER->at ($NEXT_TICK);
2938 $TICK_WATCHER->start;
2939
2940 $LOAD = ($NOW - $tick_start) / $TICK; 3642 $LOAD = ($NOW - $tick_start) / $TICK;
2941 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3643 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2942 3644
2943 _post_tick; 3645 _post_tick;
2944 3646};
2945 3647$TICK_WATCHER->priority (EV::MAXPRI);
2946 },
2947);
2948 3648
2949{ 3649{
2950 BDB::max_poll_time $TICK * 0.1; 3650 # configure BDB
2951 $BDB_POLL_WATCHER = Event->io ( 3651
2952 reentrant => 0,
2953 fd => BDB::poll_fileno,
2954 poll => 'r',
2955 prio => 0,
2956 data => WF_AUTOCANCEL,
2957 cb => \&BDB::poll_cb,
2958 );
2959 BDB::min_parallel 8; 3652 BDB::min_parallel 8;
2960 3653 BDB::max_poll_reqs $TICK * 0.1;
2961 BDB::set_sync_prepare { 3654 $Coro::BDB::WATCHER->priority (1);
2962 my $status;
2963 my $current = $Coro::current;
2964 (
2965 sub {
2966 $status = $!;
2967 $current->ready; undef $current;
2968 },
2969 sub {
2970 Coro::schedule while defined $current;
2971 $! = $status;
2972 },
2973 )
2974 };
2975 3655
2976 unless ($DB_ENV) { 3656 unless ($DB_ENV) {
2977 $DB_ENV = BDB::db_env_create; 3657 $DB_ENV = BDB::db_env_create;
3658 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3659 | BDB::LOG_AUTOREMOVE, 1);
3660 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3661 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2978 3662
2979 cf::sync_job { 3663 cf::sync_job {
2980 eval { 3664 eval {
2981 BDB::db_env_open 3665 BDB::db_env_open
2982 $DB_ENV, 3666 $DB_ENV,
… …
2984 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3668 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2985 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3669 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2986 0666; 3670 0666;
2987 3671
2988 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3672 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2989
2990 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2991 $DB_ENV->set_lk_detect;
2992 }; 3673 };
2993 3674
2994 cf::cleanup "db_env_open(db): $@" if $@; 3675 cf::cleanup "db_env_open(db): $@" if $@;
2995 }; 3676 };
2996 } 3677 }
3678
3679 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3680 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3681 };
3682 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3683 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3684 };
3685 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3686 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3687 };
2997} 3688}
2998 3689
2999{ 3690{
3691 # configure IO::AIO
3692
3000 IO::AIO::min_parallel 8; 3693 IO::AIO::min_parallel 8;
3001
3002 undef $Coro::AIO::WATCHER;
3003 IO::AIO::max_poll_time $TICK * 0.1; 3694 IO::AIO::max_poll_time $TICK * 0.1;
3004 $AIO_POLL_WATCHER = Event->io ( 3695 $Coro::AIO::WATCHER->priority (1);
3005 reentrant => 0,
3006 data => WF_AUTOCANCEL,
3007 fd => IO::AIO::poll_fileno,
3008 poll => 'r',
3009 prio => 6,
3010 cb => \&IO::AIO::poll_cb,
3011 );
3012} 3696}
3013 3697
3014my $_log_backtrace; 3698my $_log_backtrace;
3015 3699
3016sub _log_backtrace { 3700sub _log_backtrace {
… …
3020 3704
3021 # limit the # of concurrent backtraces 3705 # limit the # of concurrent backtraces
3022 if ($_log_backtrace < 2) { 3706 if ($_log_backtrace < 2) {
3023 ++$_log_backtrace; 3707 ++$_log_backtrace;
3024 async { 3708 async {
3709 $Coro::current->{desc} = "abt $msg";
3710
3025 my @bt = fork_call { 3711 my @bt = fork_call {
3026 @addr = map { sprintf "%x", $_ } @addr; 3712 @addr = map { sprintf "%x", $_ } @addr;
3027 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3713 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3028 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3714 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3029 or die "addr2line: $!"; 3715 or die "addr2line: $!";

Diff Legend

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