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.314 by root, Mon Jul 23 16:53:15 2007 UTC vs.
Revision 1.442 by root, Sun Aug 31 09:03:31 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
24use 5.10.0;
3use utf8; 25use utf8;
4use strict; 26use strict "vars", "subs";
5 27
6use Symbol; 28use Symbol;
7use List::Util; 29use List::Util;
8use Socket; 30use Socket;
9use Storable; 31use EV;
10use Event;
11use Opcode; 32use Opcode;
12use Safe; 33use Safe;
13use Safe::Hole; 34use Safe::Hole;
35use Storable ();
14 36
15use Coro 3.61 (); 37use Coro ();
16use Coro::State; 38use Coro::State;
17use Coro::Handle; 39use Coro::Handle;
40use Coro::EV;
18use Coro::Event; 41use Coro::AnyEvent;
19use Coro::Timer; 42use Coro::Timer;
20use Coro::Signal; 43use Coro::Signal;
21use Coro::Semaphore; 44use Coro::Semaphore;
45use Coro::AnyEvent;
22use Coro::AIO; 46use Coro::AIO;
47use Coro::BDB 1.6;
23use Coro::Storable; 48use Coro::Storable;
49use Coro::Util ();
24 50
25use JSON::XS 1.4 (); 51use JSON::XS 2.01 ();
26use BDB (); 52use BDB ();
27use Data::Dumper; 53use Data::Dumper;
28use Digest::MD5; 54use Digest::MD5;
29use Fcntl; 55use Fcntl;
30use YAML::Syck (); 56use YAML ();
31use IO::AIO 2.32 (); 57use IO::AIO ();
32use Time::HiRes; 58use Time::HiRes;
33use Compress::LZF; 59use Compress::LZF;
34use Digest::MD5 (); 60use Digest::MD5 ();
61
62AnyEvent::detect;
35 63
36# configure various modules to our taste 64# configure various modules to our taste
37# 65#
38$Storable::canonical = 1; # reduce rsync transfers 66$Storable::canonical = 1; # reduce rsync transfers
39Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 67Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
40Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 68Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
41
42$Event::Eval = 1; # no idea why this is required, but it is
43
44# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
45$YAML::Syck::ImplicitUnicode = 1;
46 69
47$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
48 71
49sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 72sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
50 73
69our $TMPDIR = "$LOCALDIR/" . tmpdir; 92our $TMPDIR = "$LOCALDIR/" . tmpdir;
70our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 93our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
71our $PLAYERDIR = "$LOCALDIR/" . playerdir; 94our $PLAYERDIR = "$LOCALDIR/" . playerdir;
72our $RANDOMDIR = "$LOCALDIR/random"; 95our $RANDOMDIR = "$LOCALDIR/random";
73our $BDBDIR = "$LOCALDIR/db"; 96our $BDBDIR = "$LOCALDIR/db";
97our %RESOURCE;
74 98
75our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 99our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
76our $TICK_WATCHER;
77our $AIO_POLL_WATCHER;
78our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 100our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
79our $NEXT_TICK; 101our $NEXT_TICK;
80our $NOW;
81our $USE_FSYNC = 1; # use fsync to write maps - default off 102our $USE_FSYNC = 1; # use fsync to write maps - default off
82 103
104our $BDB_DEADLOCK_WATCHER;
105our $BDB_CHECKPOINT_WATCHER;
83our $BDB_POLL_WATCHER; 106our $BDB_TRICKLE_WATCHER;
84our $DB_ENV; 107our $DB_ENV;
85 108
86our %CFG; 109our %CFG;
87 110
88our $UPTIME; $UPTIME ||= time; 111our $UPTIME; $UPTIME ||= time;
89our $RUNTIME; 112our $RUNTIME;
113our $NOW;
90 114
91our %PLAYER; # all users 115our (%PLAYER, %PLAYER_LOADING); # all users
92our %MAP; # all maps 116our (%MAP, %MAP_LOADING ); # all maps
93our $LINK_MAP; # the special {link} map, which is always available 117our $LINK_MAP; # the special {link} map, which is always available
94 118
95# used to convert map paths into valid unix filenames by replacing / by ∕ 119# used to convert map paths into valid unix filenames by replacing / by ∕
96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 120our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
97 121
98our $LOAD; # a number between 0 (idle) and 1 (too many objects) 122our $LOAD; # a number between 0 (idle) and 1 (too many objects)
99our $LOADAVG; # same thing, but with alpha-smoothing 123our $LOADAVG; # same thing, but with alpha-smoothing
124our $JITTER; # average jitter
100our $tick_start; # for load detecting purposes 125our $TICK_START; # for load detecting purposes
101 126
102binmode STDOUT; 127binmode STDOUT;
103binmode STDERR; 128binmode STDERR;
104 129
105# read virtual server time, if available 130# read virtual server time, if available
158 183
159The raw value load value from the last tick. 184The raw value load value from the last tick.
160 185
161=item %cf::CFG 186=item %cf::CFG
162 187
163Configuration for the server, loaded from C</etc/crossfire/config>, or 188Configuration for the server, loaded from C</etc/deliantra-server/config>, or
164from wherever your confdir points to. 189from wherever your confdir points to.
165 190
166=item cf::wait_for_tick, cf::wait_for_tick_begin 191=item cf::wait_for_tick, cf::wait_for_tick_begin
167 192
168These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 193These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
186 $msg .= "\n" 211 $msg .= "\n"
187 unless $msg =~ /\n$/; 212 unless $msg =~ /\n$/;
188 213
189 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 214 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
190 215
191 utf8::encode $msg;
192 LOG llevError, $msg; 216 LOG llevError, $msg;
193 }; 217 };
194} 218}
219
220$Coro::State::DIEHOOK = sub {
221 return unless $^S eq 0; # "eq", not "=="
222
223 if ($Coro::current == $Coro::main) {#d#
224 warn "DIEHOOK called in main context, Coro bug?\n";#d#
225 return;#d#
226 }#d#
227
228 # kill coroutine otherwise
229 warn Carp::longmess $_[0];
230 Coro::terminate
231};
232
233$SIG{__DIE__} = sub { }; #d#?
195 234
196@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 235@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
197@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 236@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
198@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 237@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
199@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 238@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
206for my $pkg (qw( 245for my $pkg (qw(
207 cf::global cf::attachable 246 cf::global cf::attachable
208 cf::object cf::object::player 247 cf::object cf::object::player
209 cf::client cf::player 248 cf::client cf::player
210 cf::arch cf::living 249 cf::arch cf::living
250 cf::map cf::mapspace
211 cf::map cf::party cf::region 251 cf::party cf::region
212)) { 252)) {
213 no strict 'refs';
214 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 253 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
215} 254}
216 255
217$Event::DIED = sub { 256$EV::DIED = sub {
218 warn "error in event callback: @_"; 257 warn "error in event callback: @_";
219}; 258};
220 259
221############################################################################# 260#############################################################################
222 261
245 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 284 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
246 $d 285 $d
247 } || "[unable to dump $_[0]: '$@']"; 286 } || "[unable to dump $_[0]: '$@']";
248} 287}
249 288
250=item $ref = cf::from_json $json 289=item $ref = cf::decode_json $json
251 290
252Converts a JSON string into the corresponding perl data structure. 291Converts a JSON string into the corresponding perl data structure.
253 292
254=item $json = cf::to_json $ref 293=item $json = cf::encode_json $ref
255 294
256Converts a perl data structure into its JSON representation. 295Converts a perl data structure into its JSON representation.
257 296
258=cut 297=cut
259 298
260our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 299our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
261 300
262sub to_json ($) { $json_coder->encode ($_[0]) } 301sub encode_json($) { $json_coder->encode ($_[0]) }
263sub from_json ($) { $json_coder->decode ($_[0]) } 302sub decode_json($) { $json_coder->decode ($_[0]) }
264 303
265=item cf::lock_wait $string 304=item cf::lock_wait $string
266 305
267Wait until the given lock is available. See cf::lock_acquire. 306Wait until the given lock is available. See cf::lock_acquire.
268 307
271Wait until the given lock is available and then acquires it and returns 310Wait until the given lock is available and then acquires it and returns
272a Coro::guard object. If the guard object gets destroyed (goes out of scope, 311a Coro::guard object. If the guard object gets destroyed (goes out of scope,
273for example when the coroutine gets canceled), the lock is automatically 312for example when the coroutine gets canceled), the lock is automatically
274returned. 313returned.
275 314
315Locks are *not* recursive, locking from the same coro twice results in a
316deadlocked coro.
317
276Lock names should begin with a unique identifier (for example, cf::map::find 318Lock names should begin with a unique identifier (for example, cf::map::find
277uses map_find and cf::map::load uses map_load). 319uses map_find and cf::map::load uses map_load).
278 320
279=item $locked = cf::lock_active $string 321=item $locked = cf::lock_active $string
280 322
281Return true if the lock is currently active, i.e. somebody has locked it. 323Return true if the lock is currently active, i.e. somebody has locked it.
282 324
283=cut 325=cut
284 326
285our %LOCK; 327our %LOCK;
328our %LOCKER;#d#
286 329
287sub lock_wait($) { 330sub lock_wait($) {
288 my ($key) = @_; 331 my ($key) = @_;
332
333 if ($LOCKER{$key} == $Coro::current) {#d#
334 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
335 return;#d#
336 }#d#
289 337
290 # wait for lock, if any 338 # wait for lock, if any
291 while ($LOCK{$key}) { 339 while ($LOCK{$key}) {
292 push @{ $LOCK{$key} }, $Coro::current; 340 push @{ $LOCK{$key} }, $Coro::current;
293 Coro::schedule; 341 Coro::schedule;
299 347
300 # wait, to be sure we are not locked 348 # wait, to be sure we are not locked
301 lock_wait $key; 349 lock_wait $key;
302 350
303 $LOCK{$key} = []; 351 $LOCK{$key} = [];
352 $LOCKER{$key} = $Coro::current;#d#
304 353
305 Coro::guard { 354 Coro::guard {
355 delete $LOCKER{$key};#d#
306 # wake up all waiters, to be on the safe side 356 # wake up all waiters, to be on the safe side
307 $_->ready for @{ delete $LOCK{$key} }; 357 $_->ready for @{ delete $LOCK{$key} };
308 } 358 }
309} 359}
310 360
313 363
314 ! ! $LOCK{$key} 364 ! ! $LOCK{$key}
315} 365}
316 366
317sub freeze_mainloop { 367sub freeze_mainloop {
318 return unless $TICK_WATCHER->is_active; 368 tick_inhibit_inc;
319 369
320 my $guard = Coro::guard { 370 Coro::guard \&tick_inhibit_dec;
321 $TICK_WATCHER->start;
322 };
323 $TICK_WATCHER->stop;
324 $guard
325} 371}
326 372
373=item cf::periodic $interval, $cb
374
375Like EV::periodic, but randomly selects a starting point so that the actions
376get spread over timer.
377
378=cut
379
380sub periodic($$) {
381 my ($interval, $cb) = @_;
382
383 my $start = rand List::Util::min 180, $interval;
384
385 EV::periodic $start, $interval, 0, $cb
386}
387
327=item cf::get_slot $time[, $priority] 388=item cf::get_slot $time[, $priority[, $name]]
328 389
329Allocate $time seconds of blocking CPU time at priority C<$priority>: 390Allocate $time seconds of blocking CPU time at priority C<$priority>:
330This call blocks and returns only when you have at least C<$time> seconds 391This call blocks and returns only when you have at least C<$time> seconds
331of cpu time till the next tick. The slot is only valid till the next cede. 392of cpu time till the next tick. The slot is only valid till the next cede.
332 393
394The optional C<$name> can be used to identify the job to run. It might be
395used for statistical purposes and should identify the same time-class.
396
333Useful for short background jobs. 397Useful for short background jobs.
334 398
335=cut 399=cut
336 400
337our @SLOT_QUEUE; 401our @SLOT_QUEUE;
338our $SLOT_QUEUE; 402our $SLOT_QUEUE;
339 403
340$SLOT_QUEUE->cancel if $SLOT_QUEUE; 404$SLOT_QUEUE->cancel if $SLOT_QUEUE;
341$SLOT_QUEUE = Coro::async { 405$SLOT_QUEUE = Coro::async {
406 $Coro::current->desc ("timeslot manager");
407
342 my $signal = new Coro::Signal; 408 my $signal = new Coro::Signal;
343 409
344 while () { 410 while () {
345 next_job: 411 next_job:
346 my $avail = cf::till_tick; 412 my $avail = cf::till_tick;
354 } 420 }
355 } 421 }
356 } 422 }
357 423
358 if (@SLOT_QUEUE) { 424 if (@SLOT_QUEUE) {
359 # we do not use wait_For_tick() as it returns immediately when tick is inactive 425 # we do not use wait_for_tick() as it returns immediately when tick is inactive
360 push @cf::WAIT_FOR_TICK, $signal; 426 push @cf::WAIT_FOR_TICK, $signal;
361 $signal->wait; 427 $signal->wait;
362 } else { 428 } else {
363 Coro::schedule; 429 Coro::schedule;
364 } 430 }
365 } 431 }
366}; 432};
367 433
368sub get_slot($;$) { 434sub get_slot($;$$) {
435 return if tick_inhibit || $Coro::current == $Coro::main;
436
369 my ($time, $pri) = @_; 437 my ($time, $pri, $name) = @_;
370 438
439 $time = $TICK * .6 if $time > $TICK * .6;
440 my $sig = new Coro::Signal;
441
371 push @SLOT_QUEUE, [$time, $pri, my $sig = new Coro::Signal]; 442 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
372 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 443 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
373 $SLOT_QUEUE->ready; 444 $SLOT_QUEUE->ready;
374 $sig->wait; 445 $sig->wait;
375} 446}
376 447
384 455
385BEGIN { *async = \&Coro::async_pool } 456BEGIN { *async = \&Coro::async_pool }
386 457
387=item cf::sync_job { BLOCK } 458=item cf::sync_job { BLOCK }
388 459
389The design of Crossfire TRT requires that the main coroutine ($Coro::main) 460The design of Deliantra requires that the main coroutine ($Coro::main)
390is always able to handle events or runnable, as Crossfire TRT is only 461is always able to handle events or runnable, as Deliantra is only
391partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 462partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
392acceptable. 463acceptable.
393 464
394If it must be done, put the blocking parts into C<sync_job>. This will run 465If it must be done, put the blocking parts into C<sync_job>. This will run
395the given BLOCK in another coroutine while waiting for the result. The 466the given BLOCK in another coroutine while waiting for the result. The
400 471
401sub sync_job(&) { 472sub sync_job(&) {
402 my ($job) = @_; 473 my ($job) = @_;
403 474
404 if ($Coro::current == $Coro::main) { 475 if ($Coro::current == $Coro::main) {
405 my $time = Event::time; 476 my $time = EV::time;
406 477
407 # this is the main coro, too bad, we have to block 478 # this is the main coro, too bad, we have to block
408 # till the operation succeeds, freezing the server :/ 479 # till the operation succeeds, freezing the server :/
409 480
410 # TODO: use suspend/resume instead 481 LOG llevError, Carp::longmess "sync job";#d#
411 # (but this is cancel-safe) 482
412 my $freeze_guard = freeze_mainloop; 483 my $freeze_guard = freeze_mainloop;
413 484
414 my $busy = 1; 485 my $busy = 1;
415 my @res; 486 my @res;
416 487
417 (async { 488 (async {
489 $Coro::current->desc ("sync job coro");
418 @res = eval { $job->() }; 490 @res = eval { $job->() };
419 warn $@ if $@; 491 warn $@ if $@;
420 undef $busy; 492 undef $busy;
421 })->prio (Coro::PRIO_MAX); 493 })->prio (Coro::PRIO_MAX);
422 494
423 while ($busy) { 495 while ($busy) {
424 Coro::cede or Event::one_event; 496 if (Coro::nready) {
497 Coro::cede_notself;
498 } else {
499 EV::loop EV::LOOP_ONESHOT;
425 } 500 }
501 }
426 502
427 $time = Event::time - $time; 503 my $time = EV::time - $time;
428 504
429 LOG llevError | logBacktrace, Carp::longmess "long sync job"
430 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
431
432 $tick_start += $time; # do not account sync jobs to server load 505 $TICK_START += $time; # do not account sync jobs to server load
433 506
434 wantarray ? @res : $res[0] 507 wantarray ? @res : $res[0]
435 } else { 508 } else {
436 # we are in another coroutine, how wonderful, everything just works 509 # we are in another coroutine, how wonderful, everything just works
437 510
462=item fork_call { }, $args 535=item fork_call { }, $args
463 536
464Executes the given code block with the given arguments in a seperate 537Executes the given code block with the given arguments in a seperate
465process, returning the results. Everything must be serialisable with 538process, returning the results. Everything must be serialisable with
466Coro::Storable. May, of course, block. Note that the executed sub may 539Coro::Storable. May, of course, block. Note that the executed sub may
467never block itself or use any form of Event handling. 540never block itself or use any form of event handling.
468 541
469=cut 542=cut
470
471sub _store_scalar {
472 open my $fh, ">", \my $buf
473 or die "fork_call: cannot open fh-to-buf in child : $!";
474 Storable::store_fd $_[0], $fh;
475 close $fh;
476
477 $buf
478}
479 543
480sub fork_call(&@) { 544sub fork_call(&@) {
481 my ($cb, @args) = @_; 545 my ($cb, @args) = @_;
482 546
483# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 547 # we seemingly have to make a local copy of the whole thing,
484# or die "socketpair: $!"; 548 # otherwise perl prematurely frees the stuff :/
485 pipe my $fh1, my $fh2 549 # TODO: investigate and fix (likely this will be rather laborious)
486 or die "pipe: $!";
487 550
488 if (my $pid = fork) { 551 my @res = Coro::Util::fork_eval {
489 close $fh2;
490
491 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
492 warn "pst<$res>" unless $res =~ /^pst/;
493 $res = Coro::Storable::thaw $res;
494
495 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
496
497 Carp::confess $$res unless "ARRAY" eq ref $res;
498
499 return wantarray ? @$res : $res->[-1];
500 } else {
501 reset_signals; 552 reset_signals;
502 local $SIG{__WARN__}; 553 &$cb
503 local $SIG{__DIE__}; 554 }, @args;
504 # just in case, this hack effectively disables event
505 # in the child. cleaner and slower would be canceling all watchers,
506 # but this works for the time being.
507 local $Coro::idle;
508 $Coro::current->prio (Coro::PRIO_MAX);
509 555
510 eval { 556 wantarray ? @res : $res[-1]
511 close $fh1; 557}
512 558
513 my @res = eval { $cb->(@args) }; 559=item $coin = coin_from_name $name
514 560
515 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res; 561=cut
516 close $fh2;
517 };
518 562
519 warn $@ if $@; 563our %coin_alias = (
520 _exit 0; 564 "silver" => "silvercoin",
521 } 565 "silvercoin" => "silvercoin",
566 "silvercoins" => "silvercoin",
567 "gold" => "goldcoin",
568 "goldcoin" => "goldcoin",
569 "goldcoins" => "goldcoin",
570 "platinum" => "platinacoin",
571 "platinumcoin" => "platinacoin",
572 "platinumcoins" => "platinacoin",
573 "platina" => "platinacoin",
574 "platinacoin" => "platinacoin",
575 "platinacoins" => "platinacoin",
576 "royalty" => "royalty",
577 "royalties" => "royalty",
578);
579
580sub coin_from_name($) {
581 $coin_alias{$_[0]}
582 ? cf::arch::find $coin_alias{$_[0]}
583 : undef
522} 584}
523 585
524=item $value = cf::db_get $family => $key 586=item $value = cf::db_get $family => $key
525 587
526Returns a single value from the environment database. 588Returns a single value from the environment database.
528=item cf::db_put $family => $key => $value 590=item cf::db_put $family => $key => $value
529 591
530Stores the given C<$value> in the family. It can currently store binary 592Stores the given C<$value> in the family. It can currently store binary
531data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 593data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
532 594
595=item $db = cf::db_table "name"
596
597Create and/or open a new database table. The string must not be "db" and must be unique
598within each server.
599
533=cut 600=cut
601
602sub db_table($) {
603 my ($name) = @_;
604 my $db = BDB::db_create $DB_ENV;
605
606 eval {
607 $db->set_flags (BDB::CHKSUM);
608
609 utf8::encode $name;
610 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
611 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
612 cf::cleanup "db_open(db): $!" if $!;
613 };
614 cf::cleanup "db_open(db): $@" if $@;
615
616 $db
617}
534 618
535our $DB; 619our $DB;
536 620
537sub db_init { 621sub db_init {
538 unless ($DB) {
539 $DB = BDB::db_create $DB_ENV;
540
541 cf::sync_job { 622 cf::sync_job {
542 eval { 623 $DB ||= db_table "db";
543 $DB->set_flags (BDB::CHKSUM);
544
545 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
546 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
547 cf::cleanup "db_open(db): $!" if $!;
548 };
549 cf::cleanup "db_open(db): $@" if $@;
550 };
551 } 624 };
552} 625}
553 626
554sub db_get($$) { 627sub db_get($$) {
555 my $key = "$_[0]/$_[1]"; 628 my $key = "$_[0]/$_[1]";
556 629
606 if (1) { 679 if (1) {
607 $md5 = 680 $md5 =
608 join "\x00", 681 join "\x00",
609 $processversion, 682 $processversion,
610 map { 683 map {
611 Coro::cede; 684 cf::cede_to_tick;
612 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 685 ($src->[$_], Digest::MD5::md5_hex $data[$_])
613 } 0.. $#$src; 686 } 0.. $#$src;
614 687
615 688
616 my $dbmd5 = db_get cache => "$id/md5"; 689 my $dbmd5 = db_get cache => "$id/md5";
660attach callbacks/event handlers (a collection of which is called an "attachment") 733attach callbacks/event handlers (a collection of which is called an "attachment")
661to it. All such attachable objects support the following methods. 734to it. All such attachable objects support the following methods.
662 735
663In the following description, CLASS can be any of C<global>, C<object> 736In the following description, CLASS can be any of C<global>, C<object>
664C<player>, C<client> or C<map> (i.e. the attachable objects in 737C<player>, C<client> or C<map> (i.e. the attachable objects in
665Crossfire TRT). 738Deliantra).
666 739
667=over 4 740=over 4
668 741
669=item $attachable->attach ($attachment, key => $value...) 742=item $attachable->attach ($attachment, key => $value...)
670 743
952 } 1025 }
953 1026
954 0 1027 0
955} 1028}
956 1029
957=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1030=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
958 1031
959=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1032=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
960 1033
961Generate an object-specific event with the given arguments. 1034Generate an object-specific event with the given arguments.
962 1035
968 1041
969=cut 1042=cut
970 1043
971############################################################################# 1044#############################################################################
972# object support 1045# object support
973#
974 1046
1047sub _object_equal($$);
1048sub _object_equal($$) {
1049 my ($a, $b) = @_;
1050
1051 return 0 unless (ref $a) eq (ref $b);
1052
1053 if ("HASH" eq ref $a) {
1054 my @ka = keys %$a;
1055 my @kb = keys %$b;
1056
1057 return 0 if @ka != @kb;
1058
1059 for (0 .. $#ka) {
1060 return 0 unless $ka[$_] eq $kb[$_];
1061 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1062 }
1063
1064 } elsif ("ARRAY" eq ref $a) {
1065
1066 return 0 if @$a != @$b;
1067
1068 for (0 .. $#$a) {
1069 return 0 unless _object_equal $a->[$_], $b->[$_];
1070 }
1071
1072 } elsif ($a ne $b) {
1073 return 0;
1074 }
1075
1076 1
1077}
1078
1079our $SLOW_MERGES;#d#
975sub _can_merge { 1080sub _can_merge {
976 my ($ob1, $ob2) = @_; 1081 my ($ob1, $ob2) = @_;
977 1082
978 local $Storable::canonical = 1; 1083 ++$SLOW_MERGES;#d#
979 my $fob1 = Storable::freeze $ob1;
980 my $fob2 = Storable::freeze $ob2;
981 1084
982 $fob1 eq $fob2 1085 # we do the slow way here
1086 return _object_equal $ob1, $ob2
983} 1087}
984 1088
985sub reattach { 1089sub reattach {
986 # basically do the same as instantiate, without calling instantiate 1090 # basically do the same as instantiate, without calling instantiate
987 my ($obj) = @_; 1091 my ($obj) = @_;
988 1092
1093 # no longer needed after getting rid of delete_package?
989 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1094 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
990 1095
991 my $registry = $obj->registry; 1096 my $registry = $obj->registry;
992 1097
993 @$registry = (); 1098 @$registry = ();
994 1099
1009cf::attachable->attach ( 1114cf::attachable->attach (
1010 prio => -1000000, 1115 prio => -1000000,
1011 on_instantiate => sub { 1116 on_instantiate => sub {
1012 my ($obj, $data) = @_; 1117 my ($obj, $data) = @_;
1013 1118
1014 $data = from_json $data; 1119 $data = decode_json $data;
1015 1120
1016 for (@$data) { 1121 for (@$data) {
1017 my ($name, $args) = @$_; 1122 my ($name, $args) = @$_;
1018 1123
1019 $obj->attach ($name, %{$args || {} }); 1124 $obj->attach ($name, %{$args || {} });
1035sub object_freezer_save { 1140sub object_freezer_save {
1036 my ($filename, $rdata, $objs) = @_; 1141 my ($filename, $rdata, $objs) = @_;
1037 1142
1038 sync_job { 1143 sync_job {
1039 if (length $$rdata) { 1144 if (length $$rdata) {
1145 utf8::decode (my $decname = $filename);
1040 warn sprintf "saving %s (%d,%d)\n", 1146 warn sprintf "saving %s (%d,%d)\n",
1041 $filename, length $$rdata, scalar @$objs; 1147 $decname, length $$rdata, scalar @$objs;
1042 1148
1043 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1149 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1044 chmod SAVE_MODE, $fh; 1150 aio_chmod $fh, SAVE_MODE;
1045 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1151 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1046 aio_fsync $fh if $cf::USE_FSYNC; 1152 aio_fsync $fh if $cf::USE_FSYNC;
1047 close $fh; 1153 aio_close $fh;
1048 1154
1049 if (@$objs) { 1155 if (@$objs) {
1050 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1156 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1051 chmod SAVE_MODE, $fh; 1157 aio_chmod $fh, SAVE_MODE;
1052 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1158 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1053 aio_write $fh, 0, (length $data), $data, 0; 1159 aio_write $fh, 0, (length $data), $data, 0;
1054 aio_fsync $fh if $cf::USE_FSYNC; 1160 aio_fsync $fh if $cf::USE_FSYNC;
1055 close $fh; 1161 aio_close $fh;
1056 aio_rename "$filename.pst~", "$filename.pst"; 1162 aio_rename "$filename.pst~", "$filename.pst";
1057 } 1163 }
1058 } else { 1164 } else {
1059 aio_unlink "$filename.pst"; 1165 aio_unlink "$filename.pst";
1060 } 1166 }
1065 } 1171 }
1066 } else { 1172 } else {
1067 aio_unlink $filename; 1173 aio_unlink $filename;
1068 aio_unlink "$filename.pst"; 1174 aio_unlink "$filename.pst";
1069 } 1175 }
1070 } 1176 };
1071} 1177}
1072 1178
1073sub object_freezer_as_string { 1179sub object_freezer_as_string {
1074 my ($rdata, $objs) = @_; 1180 my ($rdata, $objs) = @_;
1075 1181
1087 or return; 1193 or return;
1088 1194
1089 unless (aio_stat "$filename.pst") { 1195 unless (aio_stat "$filename.pst") {
1090 (aio_load "$filename.pst", $av) >= 0 1196 (aio_load "$filename.pst", $av) >= 0
1091 or return; 1197 or return;
1198
1092 $av = eval { (Storable::thaw $av)->{objs} }; 1199 my $st = eval { Coro::Storable::thaw $av };
1200 $av = $st->{objs};
1093 } 1201 }
1094 1202
1203 utf8::decode (my $decname = $filename);
1095 warn sprintf "loading %s (%d)\n", 1204 warn sprintf "loading %s (%d,%d)\n",
1096 $filename, length $data, scalar @{$av || []}; 1205 $decname, length $data, scalar @{$av || []};
1206
1097 return ($data, $av); 1207 ($data, $av)
1098} 1208}
1099 1209
1100=head2 COMMAND CALLBACKS 1210=head2 COMMAND CALLBACKS
1101 1211
1102=over 4 1212=over 4
1175 my ($pl, $buf) = @_; 1285 my ($pl, $buf) = @_;
1176 1286
1177 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) }; 1287 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1178 1288
1179 if (ref $msg) { 1289 if (ref $msg) {
1290 my ($type, $reply, @payload) =
1291 "ARRAY" eq ref $msg
1292 ? @$msg
1293 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1294
1295 my @reply;
1296
1180 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1297 if (my $cb = $EXTCMD{$type}) {
1181 if (my %reply = $cb->($pl, $msg)) { 1298 @reply = $cb->($pl, @payload);
1182 $pl->ext_reply ($msg->{msgid}, %reply);
1183 }
1184 } 1299 }
1300
1301 $pl->ext_reply ($reply, @reply)
1302 if $reply;
1303
1185 } else { 1304 } else {
1186 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1305 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1187 } 1306 }
1188 1307
1189 cf::override; 1308 cf::override;
1216 1335
1217 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1336 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1218 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1337 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1219 1338
1220 $ext{source} = 1339 $ext{source} =
1221 "package $pkg; use strict; use utf8;\n" 1340 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1222 . "#line 1 \"$path\"\n{\n" 1341 . "#line 1 \"$path\"\n{\n"
1223 . $source 1342 . $source
1224 . "\n};\n1"; 1343 . "\n};\n1";
1225 1344
1226 $todo{$base} = \%ext; 1345 $todo{$base} = \%ext;
1242 my $msg = $@ ? "$v->{path}: $@\n" 1361 my $msg = $@ ? "$v->{path}: $@\n"
1243 : "$v->{base}: extension inactive.\n"; 1362 : "$v->{base}: extension inactive.\n";
1244 1363
1245 if (exists $v->{meta}{mandatory}) { 1364 if (exists $v->{meta}{mandatory}) {
1246 warn $msg; 1365 warn $msg;
1247 warn "mandatory extension failed to load, exiting.\n"; 1366 cf::cleanup "mandatory extension failed to load, exiting.";
1248 exit 1;
1249 } 1367 }
1250 1368
1251 warn $msg; 1369 warn $msg;
1252 } 1370 }
1253 1371
1278use Coro::AIO; 1396use Coro::AIO;
1279 1397
1280=head3 cf::player 1398=head3 cf::player
1281 1399
1282=over 4 1400=over 4
1401
1402=item cf::player::num_playing
1403
1404Returns the official number of playing players, as per the Crossfire metaserver rules.
1405
1406=cut
1407
1408sub num_playing {
1409 scalar grep
1410 $_->ob->map
1411 && !$_->hidden
1412 && !$_->ob->flag (cf::FLAG_WIZ),
1413 cf::player::list
1414}
1283 1415
1284=item cf::player::find $login 1416=item cf::player::find $login
1285 1417
1286Returns the given player object, loading it if necessary (might block). 1418Returns the given player object, loading it if necessary (might block).
1287 1419
1323 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1455 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1324 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1456 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1325 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1457 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1326 aio_unlink +(playerdir $login) . "/$login.pl"; 1458 aio_unlink +(playerdir $login) . "/$login.pl";
1327 1459
1328 my $pl = load_pl path $login 1460 my $f = new_from_file cf::object::thawer path $login
1329 or return; 1461 or return;
1462
1463 my $pl = cf::player::load_pl $f
1464 or return;
1465
1466 local $cf::PLAYER_LOADING{$login} = $pl;
1467 $f->resolve_delayed_derefs;
1330 $cf::PLAYER{$login} = $pl 1468 $cf::PLAYER{$login} = $pl
1331 } 1469 }
1332 } 1470 }
1333} 1471}
1334 1472
1343 return if $pl->{deny_save}; 1481 return if $pl->{deny_save};
1344 1482
1345 aio_mkdir playerdir $pl, 0770; 1483 aio_mkdir playerdir $pl, 0770;
1346 $pl->{last_save} = $cf::RUNTIME; 1484 $pl->{last_save} = $cf::RUNTIME;
1347 1485
1486 cf::get_slot 0.01;
1487
1348 $pl->save_pl ($path); 1488 $pl->save_pl ($path);
1349 Coro::cede; 1489 cf::cede_to_tick;
1350} 1490}
1351 1491
1352sub new($) { 1492sub new($) {
1353 my ($login) = @_; 1493 my ($login) = @_;
1354 1494
1360 $cf::PLAYER{$login} = $self; 1500 $cf::PLAYER{$login} = $self;
1361 1501
1362 $self 1502 $self
1363} 1503}
1364 1504
1505=item $player->send_msg ($channel, $msg, $color, [extra...])
1506
1507=cut
1508
1509sub send_msg {
1510 my $ns = shift->ns
1511 or return;
1512 $ns->send_msg (@_);
1513}
1514
1365=item $pl->quit_character 1515=item $pl->quit_character
1366 1516
1367Nukes the player without looking back. If logged in, the connection will 1517Nukes the player without looking back. If logged in, the connection will
1368be destroyed. May block for a long time. 1518be destroyed. May block for a long time.
1369 1519
1377 $pl->{deny_save} = 1; 1527 $pl->{deny_save} = 1;
1378 $pl->password ("*"); # this should lock out the player until we nuked the dir 1528 $pl->password ("*"); # this should lock out the player until we nuked the dir
1379 1529
1380 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1530 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1381 $pl->deactivate; 1531 $pl->deactivate;
1532 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1533 $pl->ob->check_score;
1382 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1534 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1383 $pl->ns->destroy if $pl->ns; 1535 $pl->ns->destroy if $pl->ns;
1384 1536
1385 my $path = playerdir $pl; 1537 my $path = playerdir $pl;
1386 my $temp = "$path~$cf::RUNTIME~deleting~"; 1538 my $temp = "$path~$cf::RUNTIME~deleting~";
1422 or return []; 1574 or return [];
1423 1575
1424 my @logins; 1576 my @logins;
1425 1577
1426 for my $login (@$dirs) { 1578 for my $login (@$dirs) {
1579 my $path = path $login;
1580
1581 # a .pst is a dead give-away for a valid player
1582 # if no pst file found, open and chekc for blocked users
1583 if (aio_stat "$path.pst") {
1427 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1584 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1428 aio_read $fh, 0, 512, my $buf, 0 or next; 1585 aio_read $fh, 0, 512, my $buf, 0 or next;
1429 $buf !~ /^password -------------$/m or next; # official not-valid tag 1586 $buf !~ /^password -------------$/m or next; # official not-valid tag
1587 }
1430 1588
1431 utf8::decode $login; 1589 utf8::decode $login;
1432 push @logins, $login; 1590 push @logins, $login;
1433 } 1591 }
1434 1592
1468Expand crossfire pod fragments into protocol xml. 1626Expand crossfire pod fragments into protocol xml.
1469 1627
1470=cut 1628=cut
1471 1629
1472sub expand_cfpod { 1630sub expand_cfpod {
1473 ((my $self), (local $_)) = @_; 1631 my ($self, $pod) = @_;
1474 1632
1475 # escape & and < 1633 my @nest = [qr<\G$>, undef, ""];
1476 s/&/&amp;/g; 1634 my $xml;
1477 s/(?<![BIUGH])</&lt;/g;
1478 1635
1479 # this is buggy, it needs to properly take care of nested <'s 1636 for ($pod) {
1637 while () {
1638 if (/\G( (?: [^BCEGHITUZ&>\n\ ]+ | [BCEGHITUZ](?!<) | \ (?!>) )+ )/xgcs) {
1639 $xml .= $1;
1640 } elsif (/\G\n(?=\S)/xgcs) {
1641 $xml .= " ";
1642 } elsif (/\G\n/xgcs) {
1643 $xml .= "\n";
1644 } elsif (/\G ([BCEGHITUZ]) (< (?: <+\ | (?!<) ) )/xgcs) {
1645 my ($code, $delim) = ($1, scalar reverse $2);
1646 $delim =~ y/</>/; # delim now contains the stop sequence
1647 $delim = qr{\G\Q$delim};
1480 1648
1481 1 while 1649 my $cb;
1482 # replace B<>, I<>, U<> etc. 1650
1483 s/B<([^\>]*)>/<b>$1<\/b>/ 1651 if ($code eq "B") {
1484 || s/I<([^\>]*)>/<i>$1<\/i>/ 1652 $cb = sub { "<b>$_[0]</b>" };
1485 || s/U<([^\>]*)>/<u>$1<\/u>/ 1653 } elsif ($code eq "C") {
1486 # replace G<male|female> tags 1654 $cb = sub { "<tt>$_[0]</tt>" };
1487 || s{G<([^>|]*)\|([^>]*)>}{ 1655 } elsif ($code eq "E") {
1488 $self->gender ? $2 : $1 1656 $cb = sub { warn "E<$_[0]>\n";"&$_[0];" };
1489 }ge 1657 } elsif ($code eq "G") {
1490 # replace H<hint text> 1658 $cb = sub {
1491 || s{H<([^\>]*)>} 1659 my ($male, $female) = split /\|/, $_[0];
1492 { 1660 $self->gender ? $female : $male
1661 };
1662 } elsif ($code eq "H") {
1663 $cb = sub {
1664 (
1493 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1665 "<fg name=\"lightblue\">[$_[0] (Use hintmode to suppress hints)]</fg>",
1494 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1666 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1495 "") 1667 "",
1496 [$self->{hintmode}] 1668 )[$self->{hintmode}];
1669 };
1670 } elsif ($code eq "I") {
1671 $cb = sub { "<i>$_[0]</i>" };
1672 } elsif ($code eq "T") {
1673 $cb = sub { "<big><b>$_[0]</b></big>" };
1674 } elsif ($code eq "U") {
1675 $cb = sub { "<u>$_[0]</u>" };
1676 } elsif ($code eq "Z") {
1677 $cb = sub { };
1678 } else {
1679 die "FATAL error in expand_cfpod";
1680 }
1681
1682 push @nest, [$delim, $cb, $xml];
1683 undef $xml;
1684
1685 } elsif ($_ =~ /$nest[-1][0]/gcs) {
1686 my $nest = pop @nest;
1687
1688 if ($nest->[1]) {
1689 $xml = $nest->[2] . $nest->[1]->($xml);
1690 } else {
1691 last;
1692 }
1693 } elsif (/\G</xgcs) {
1694 $xml .= "&lt;";
1695 } elsif (/\G&/xgcs) {
1696 $xml .= "&amp;";
1697 } elsif (/\G>/xgcs) {
1698 $xml .= ">";
1699 } else {
1700 if ($pod =~ /\G(.+)/xgcs) {
1701 warn "parse error (at $1)($nest[-1][0]) while expanding cfpod:\n$pod";
1702 last;
1703 } else {
1704 warn "parse error (unclosed interior sequence at end of cfpod) while expanding cfpod:\n$pod";
1705 return "<b>Sorry, the server encountered an internal error when formatting this message, please report this.</b>";
1706 }
1497 }ge; 1707 }
1708 }
1709 }
1498 1710
1499 # create single paragraphs (very hackish) 1711 $xml
1500 s/(?<=\S)\n(?=\w)/ /g;
1501
1502 # compress some whitespace
1503 s/\s+\n/\n/g; # ws line-ends
1504 s/\n\n+/\n/g; # double lines
1505 s/^\n+//; # beginning lines
1506 s/\n+$//; # ending lines
1507
1508 $_
1509} 1712}
1510 1713
1511sub hintmode { 1714sub hintmode {
1512 $_[0]{hintmode} = $_[1] if @_ > 1; 1715 $_[0]{hintmode} = $_[1] if @_ > 1;
1513 $_[0]{hintmode} 1716 $_[0]{hintmode}
1514} 1717}
1515 1718
1516=item $player->ext_reply ($msgid, %msg) 1719=item $player->ext_reply ($msgid, @msg)
1517 1720
1518Sends an ext reply to the player. 1721Sends an ext reply to the player.
1519 1722
1520=cut 1723=cut
1521 1724
1522sub ext_reply($$%) { 1725sub ext_reply($$@) {
1523 my ($self, $id, %msg) = @_; 1726 my ($self, $id, @msg) = @_;
1524 1727
1525 $msg{msgid} = $id; 1728 $self->ns->ext_reply ($id, @msg)
1526 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1527} 1729}
1528 1730
1529=item $player->ext_event ($type, %msg) 1731=item $player->ext_msg ($type, @msg)
1530 1732
1531Sends an ext event to the client. 1733Sends an ext event to the client.
1532 1734
1533=cut 1735=cut
1534 1736
1535sub ext_event($$%) { 1737sub ext_msg($$@) {
1536 my ($self, $type, %msg) = @_; 1738 my ($self, $type, @msg) = @_;
1537 1739
1538 $self->ns->ext_event ($type, %msg); 1740 $self->ns->ext_msg ($type, @msg);
1539} 1741}
1540 1742
1541=head3 cf::region 1743=head3 cf::region
1542 1744
1543=over 4 1745=over 4
1587our $MAX_RESET = 3600; 1789our $MAX_RESET = 3600;
1588our $DEFAULT_RESET = 3000; 1790our $DEFAULT_RESET = 3000;
1589 1791
1590sub generate_random_map { 1792sub generate_random_map {
1591 my ($self, $rmp) = @_; 1793 my ($self, $rmp) = @_;
1794
1795 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1796
1592 # mit "rum" bekleckern, nicht 1797 # mit "rum" bekleckern, nicht
1593 $self->_create_random_map ( 1798 $self->_create_random_map (
1594 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1799 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1595 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1800 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1596 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1801 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1718 1923
1719# the temporary/swap location 1924# the temporary/swap location
1720sub save_path { 1925sub save_path {
1721 my ($self) = @_; 1926 my ($self) = @_;
1722 1927
1723 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1928 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1724 "$TMPDIR/$path.map" 1929 "$TMPDIR/$path.map"
1725} 1930}
1726 1931
1727# the unique path, undef == no special unique path 1932# the unique path, undef == no special unique path
1728sub uniq_path { 1933sub uniq_path {
1729 my ($self) = @_; 1934 my ($self) = @_;
1730 1935
1731 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1936 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1732 "$UNIQUEDIR/$path" 1937 "$UNIQUEDIR/$path"
1733} 1938}
1734 1939
1735# and all this just because we cannot iterate over 1940# and all this just because we cannot iterate over
1736# all maps in C++... 1941# all maps in C++...
1759 1964
1760sub load_header_from($) { 1965sub load_header_from($) {
1761 my ($self, $path) = @_; 1966 my ($self, $path) = @_;
1762 1967
1763 utf8::encode $path; 1968 utf8::encode $path;
1764 #aio_open $path, O_RDONLY, 0 1969 my $f = new_from_file cf::object::thawer $path
1765 # or return;
1766
1767 $self->_load_header ($path)
1768 or return; 1970 or return;
1971
1972 $self->_load_header ($f)
1973 or return;
1974
1975 local $MAP_LOADING{$self->{path}} = $self;
1976 $f->resolve_delayed_derefs;
1769 1977
1770 $self->{load_path} = $path; 1978 $self->{load_path} = $path;
1771 1979
1772 1 1980 1
1773} 1981}
1827sub find { 2035sub find {
1828 my ($path, $origin) = @_; 2036 my ($path, $origin) = @_;
1829 2037
1830 $path = normalise $path, $origin && $origin->path; 2038 $path = normalise $path, $origin && $origin->path;
1831 2039
2040 cf::lock_wait "map_data:$path";#d#remove
1832 cf::lock_wait "map_find:$path"; 2041 cf::lock_wait "map_find:$path";
1833 2042
1834 $cf::MAP{$path} || do { 2043 $cf::MAP{$path} || do {
2044 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1835 my $guard = cf::lock_acquire "map_find:$path"; 2045 my $guard2 = cf::lock_acquire "map_find:$path";
2046
1836 my $map = new_from_path cf::map $path 2047 my $map = new_from_path cf::map $path
1837 or return; 2048 or return;
1838 2049
1839 $map->{last_save} = $cf::RUNTIME; 2050 $map->{last_save} = $cf::RUNTIME;
1840 2051
1842 or return; 2053 or return;
1843 2054
1844 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2055 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1845 # doing this can freeze the server in a sync job, obviously 2056 # doing this can freeze the server in a sync job, obviously
1846 #$cf::WAIT_FOR_TICK->wait; 2057 #$cf::WAIT_FOR_TICK->wait;
2058 undef $guard2;
2059 undef $guard1;
1847 $map->reset; 2060 $map->reset;
1848 undef $guard;
1849 return find $path; 2061 return find $path;
1850 } 2062 }
1851 2063
1852 $cf::MAP{$path} = $map 2064 $cf::MAP{$path} = $map
1853 } 2065 }
1862 local $self->{deny_reset} = 1; # loading can take a long time 2074 local $self->{deny_reset} = 1; # loading can take a long time
1863 2075
1864 my $path = $self->{path}; 2076 my $path = $self->{path};
1865 2077
1866 { 2078 {
1867 my $guard = cf::lock_acquire "map_load:$path"; 2079 my $guard = cf::lock_acquire "map_data:$path";
1868 2080
2081 return unless $self->valid;
1869 return if $self->in_memory != cf::MAP_SWAPPED; 2082 return unless $self->in_memory == cf::MAP_SWAPPED;
1870 2083
1871 $self->in_memory (cf::MAP_LOADING); 2084 $self->in_memory (cf::MAP_LOADING);
1872 2085
1873 $self->alloc; 2086 $self->alloc;
1874 2087
1875 $self->pre_load; 2088 $self->pre_load;
1876 Coro::cede; 2089 cf::cede_to_tick;
1877 2090
2091 my $f = new_from_file cf::object::thawer $self->{load_path};
2092 $f->skip_block;
1878 $self->_load_objects ($self->{load_path}, 1) 2093 $self->_load_objects ($f)
1879 or return; 2094 or return;
1880 2095
1881 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2096 $self->post_load_original
1882 if delete $self->{load_original}; 2097 if delete $self->{load_original};
1883 2098
1884 if (my $uniq = $self->uniq_path) { 2099 if (my $uniq = $self->uniq_path) {
1885 utf8::encode $uniq; 2100 utf8::encode $uniq;
1886 if (aio_open $uniq, O_RDONLY, 0) { 2101 unless (aio_stat $uniq) {
2102 if (my $f = new_from_file cf::object::thawer $uniq) {
1887 $self->clear_unique_items; 2103 $self->clear_unique_items;
1888 $self->_load_objects ($uniq, 0); 2104 $self->_load_objects ($f);
2105 $f->resolve_delayed_derefs;
2106 }
1889 } 2107 }
1890 } 2108 }
1891 2109
1892 Coro::cede; 2110 $f->resolve_delayed_derefs;
2111
2112 cf::cede_to_tick;
1893 # now do the right thing for maps 2113 # now do the right thing for maps
1894 $self->link_multipart_objects; 2114 $self->link_multipart_objects;
1895 $self->difficulty ($self->estimate_difficulty) 2115 $self->difficulty ($self->estimate_difficulty)
1896 unless $self->difficulty; 2116 unless $self->difficulty;
1897 Coro::cede; 2117 cf::cede_to_tick;
1898 2118
1899 unless ($self->{deny_activate}) { 2119 unless ($self->{deny_activate}) {
1900 $self->decay_objects; 2120 $self->decay_objects;
1901 $self->fix_auto_apply; 2121 $self->fix_auto_apply;
1902 $self->update_buttons; 2122 $self->update_buttons;
1903 Coro::cede; 2123 cf::cede_to_tick;
1904 $self->set_darkness_map; 2124 $self->set_darkness_map;
1905 Coro::cede; 2125 cf::cede_to_tick;
1906 $self->activate; 2126 $self->activate;
1907 } 2127 }
1908 2128
2129 $self->{last_save} = $cf::RUNTIME;
2130 $self->last_access ($cf::RUNTIME);
2131
1909 $self->in_memory (cf::MAP_IN_MEMORY); 2132 $self->in_memory (cf::MAP_ACTIVE);
1910 } 2133 }
1911 2134
1912 $self->post_load; 2135 $self->post_load;
1913} 2136}
1914 2137
1923 2146
1924 $self 2147 $self
1925} 2148}
1926 2149
1927# find and load all maps in the 3x3 area around a map 2150# find and load all maps in the 3x3 area around a map
1928sub load_diag { 2151sub load_neighbours {
1929 my ($map) = @_; 2152 my ($map) = @_;
1930 2153
1931 my @diag; # diagonal neighbours 2154 my @neigh; # diagonal neighbours
1932 2155
1933 for (0 .. 3) { 2156 for (0 .. 3) {
1934 my $neigh = $map->tile_path ($_) 2157 my $neigh = $map->tile_path ($_)
1935 or next; 2158 or next;
1936 $neigh = find $neigh, $map 2159 $neigh = find $neigh, $map
1937 or next; 2160 or next;
1938 $neigh->load; 2161 $neigh->load;
1939 2162
2163 push @neigh,
1940 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2164 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1941 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2165 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1942 } 2166 }
1943 2167
1944 for (@diag) { 2168 for (grep defined $_->[0], @neigh) {
2169 my ($path, $origin) = @$_;
1945 my $neigh = find @$_ 2170 my $neigh = find $path, $origin
1946 or next; 2171 or next;
1947 $neigh->load; 2172 $neigh->load;
1948 } 2173 }
1949} 2174}
1950 2175
1955} 2180}
1956 2181
1957sub do_load_sync { 2182sub do_load_sync {
1958 my ($map) = @_; 2183 my ($map) = @_;
1959 2184
2185 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2186 if $Coro::current == $Coro::main;
2187
1960 cf::sync_job { $map->load }; 2188 cf::sync_job { $map->load };
1961} 2189}
1962 2190
1963our %MAP_PREFETCH; 2191our %MAP_PREFETCH;
1964our $MAP_PREFETCHER = undef; 2192our $MAP_PREFETCHER = undef;
1965 2193
1966sub find_async { 2194sub find_async {
1967 my ($path, $origin) = @_; 2195 my ($path, $origin, $load) = @_;
1968 2196
1969 $path = normalise $path, $origin && $origin->{path}; 2197 $path = normalise $path, $origin && $origin->{path};
1970 2198
1971 if (my $map = $cf::MAP{$path}) { 2199 if (my $map = $cf::MAP{$path}) {
1972 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2200 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1973 } 2201 }
1974 2202
1975 undef $MAP_PREFETCH{$path}; 2203 $MAP_PREFETCH{$path} |= $load;
2204
1976 $MAP_PREFETCHER ||= cf::async { 2205 $MAP_PREFETCHER ||= cf::async {
2206 $Coro::current->{desc} = "map prefetcher";
2207
1977 while (%MAP_PREFETCH) { 2208 while (%MAP_PREFETCH) {
1978 for my $path (keys %MAP_PREFETCH) { 2209 while (my ($k, $v) = each %MAP_PREFETCH) {
1979 if (my $map = find $path) { 2210 if (my $map = find $k) {
1980 $map->load; 2211 $map->load if $v;
1981 } 2212 }
1982 2213
1983 delete $MAP_PREFETCH{$path}; 2214 delete $MAP_PREFETCH{$k};
1984 } 2215 }
1985 } 2216 }
1986 undef $MAP_PREFETCHER; 2217 undef $MAP_PREFETCHER;
1987 }; 2218 };
1988 $MAP_PREFETCHER->prio (6); 2219 $MAP_PREFETCHER->prio (6);
1991} 2222}
1992 2223
1993sub save { 2224sub save {
1994 my ($self) = @_; 2225 my ($self) = @_;
1995 2226
1996 my $lock = cf::lock_acquire "map_data:" . $self->path; 2227 my $lock = cf::lock_acquire "map_data:$self->{path}";
1997 2228
1998 $self->{last_save} = $cf::RUNTIME; 2229 $self->{last_save} = $cf::RUNTIME;
1999 2230
2000 return unless $self->dirty; 2231 return unless $self->dirty;
2001 2232
2007 return if $self->{deny_save}; 2238 return if $self->{deny_save};
2008 2239
2009 local $self->{last_access} = $self->last_access;#d# 2240 local $self->{last_access} = $self->last_access;#d#
2010 2241
2011 cf::async { 2242 cf::async {
2243 $Coro::current->{desc} = "map player save";
2012 $_->contr->save for $self->players; 2244 $_->contr->save for $self->players;
2013 }; 2245 };
2246
2247 cf::get_slot 0.02;
2014 2248
2015 if ($uniq) { 2249 if ($uniq) {
2016 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2250 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2017 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2251 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2018 } else { 2252 } else {
2024 my ($self) = @_; 2258 my ($self) = @_;
2025 2259
2026 # save first because save cedes 2260 # save first because save cedes
2027 $self->save; 2261 $self->save;
2028 2262
2029 my $lock = cf::lock_acquire "map_data:" . $self->path; 2263 my $lock = cf::lock_acquire "map_data:$self->{path}";
2030 2264
2031 return if $self->players; 2265 return if $self->players;
2032 return if $self->in_memory != cf::MAP_IN_MEMORY; 2266 return if $self->in_memory != cf::MAP_ACTIVE;
2033 return if $self->{deny_save}; 2267 return if $self->{deny_save};
2034 2268
2269 $self->in_memory (cf::MAP_SWAPPED);
2270
2271 $self->deactivate;
2272 $_->clear_links_to ($self) for values %cf::MAP;
2035 $self->clear; 2273 $self->clear;
2036 $self->in_memory (cf::MAP_SWAPPED);
2037} 2274}
2038 2275
2039sub reset_at { 2276sub reset_at {
2040 my ($self) = @_; 2277 my ($self) = @_;
2041 2278
2073 if $uniq; 2310 if $uniq;
2074 } 2311 }
2075 2312
2076 delete $cf::MAP{$self->path}; 2313 delete $cf::MAP{$self->path};
2077 2314
2315 $self->deactivate;
2316 $_->clear_links_to ($self) for values %cf::MAP;
2078 $self->clear; 2317 $self->clear;
2079
2080 $_->clear_links_to ($self) for values %cf::MAP;
2081 2318
2082 $self->unlink_save; 2319 $self->unlink_save;
2083 $self->destroy; 2320 $self->destroy;
2084} 2321}
2085 2322
2086my $nuke_counter = "aaaa"; 2323my $nuke_counter = "aaaa";
2087 2324
2088sub nuke { 2325sub nuke {
2089 my ($self) = @_; 2326 my ($self) = @_;
2090 2327
2328 {
2329 my $lock = cf::lock_acquire "map_data:$self->{path}";
2330
2091 delete $cf::MAP{$self->path}; 2331 delete $cf::MAP{$self->path};
2092 2332
2093 $self->unlink_save; 2333 $self->unlink_save;
2094 2334
2095 bless $self, "cf::map"; 2335 bless $self, "cf::map";
2096 delete $self->{deny_reset}; 2336 delete $self->{deny_reset};
2097 $self->{deny_save} = 1; 2337 $self->{deny_save} = 1;
2098 $self->reset_timeout (1); 2338 $self->reset_timeout (1);
2099 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2339 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2100 2340
2101 $cf::MAP{$self->path} = $self; 2341 $cf::MAP{$self->path} = $self;
2342 }
2102 2343
2103 $self->reset; # polite request, might not happen 2344 $self->reset; # polite request, might not happen
2104} 2345}
2105 2346
2106=item $maps = cf::map::tmp_maps 2347=item $maps = cf::map::tmp_maps
2148 2389
2149sub unique_maps() { 2390sub unique_maps() {
2150 [ 2391 [
2151 map { 2392 map {
2152 utf8::decode $_; 2393 utf8::decode $_;
2153 /\.map$/ 2394 s/\.map$//; # TODO future compatibility hack
2395 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2396 ? ()
2154 ? normalise $_ 2397 : normalise $_
2155 : ()
2156 } @{ aio_readdir $UNIQUEDIR or [] } 2398 } @{ aio_readdir $UNIQUEDIR or [] }
2157 ] 2399 ]
2158} 2400}
2159 2401
2160package cf;
2161
2162=back 2402=back
2163 2403
2164=head3 cf::object 2404=head3 cf::object
2165 2405
2166=cut 2406=cut
2169 2409
2170=over 4 2410=over 4
2171 2411
2172=item $ob->inv_recursive 2412=item $ob->inv_recursive
2173 2413
2174Returns the inventory of the object _and_ their inventories, recursively. 2414Returns the inventory of the object I<and> their inventories, recursively,
2415but I<not> the object itself.
2175 2416
2176=cut 2417=cut
2177 2418
2178sub inv_recursive_; 2419sub inv_recursive_;
2179sub inv_recursive_ { 2420sub inv_recursive_ {
2182 2423
2183sub inv_recursive { 2424sub inv_recursive {
2184 inv_recursive_ inv $_[0] 2425 inv_recursive_ inv $_[0]
2185} 2426}
2186 2427
2428=item $ref = $ob->ref
2429
2430Creates and returns a persistent reference to an object that can be stored as a string.
2431
2432=item $ob = cf::object::deref ($refstring)
2433
2434returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2435even if the object actually exists. May block.
2436
2437=cut
2438
2439sub deref {
2440 my ($ref) = @_;
2441
2442 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2443 my ($uuid, $name) = ($1, $2);
2444 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2445 or return;
2446 $pl->ob->uuid eq $uuid
2447 or return;
2448
2449 $pl->ob
2450 } else {
2451 warn "$ref: cannot resolve object reference\n";
2452 undef
2453 }
2454}
2455
2187package cf; 2456package cf;
2188 2457
2189=back 2458=back
2190 2459
2191=head3 cf::object::player 2460=head3 cf::object::player
2197Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2466Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2198can be C<undef>. Does the right thing when the player is currently in a 2467can be C<undef>. Does the right thing when the player is currently in a
2199dialogue with the given NPC character. 2468dialogue with the given NPC character.
2200 2469
2201=cut 2470=cut
2471
2472our $SAY_CHANNEL = {
2473 id => "say",
2474 title => "Map",
2475 reply => "say ",
2476 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2477};
2478
2479our $CHAT_CHANNEL = {
2480 id => "chat",
2481 title => "Chat",
2482 reply => "chat ",
2483 tooltip => "Player chat and shouts, global to the server.",
2484};
2202 2485
2203# rough implementation of a future "reply" method that works 2486# rough implementation of a future "reply" method that works
2204# with dialog boxes. 2487# with dialog boxes.
2205#TODO: the first argument must go, split into a $npc->reply_to ( method 2488#TODO: the first argument must go, split into a $npc->reply_to ( method
2206sub cf::object::player::reply($$$;$) { 2489sub cf::object::player::reply($$$;$) {
2213 2496
2214 } else { 2497 } else {
2215 my $pl = $self->contr; 2498 my $pl = $self->contr;
2216 2499
2217 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2500 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2218 my $diag = $pl->{npc_dialog}; 2501 my $dialog = $pl->{npc_dialog};
2219 $diag->{pl}->ext_reply ( 2502 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2220 $diag->{id},
2221 msgtype => "reply",
2222 msg => $diag->{pl}->expand_cfpod ($msg),
2223 add_topics => []
2224 );
2225 2503
2226 } else { 2504 } else {
2227 $msg = $npc->name . " says: $msg" if $npc; 2505 $msg = $npc->name . " says: $msg" if $npc;
2228 $self->message ($msg, $flags); 2506 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2229 } 2507 }
2230 } 2508 }
2509}
2510
2511=item $object->send_msg ($channel, $msg, $color, [extra...])
2512
2513=cut
2514
2515sub cf::object::send_msg {
2516 my $pl = shift->contr
2517 or return;
2518 $pl->send_msg (@_);
2231} 2519}
2232 2520
2233=item $player_object->may ("access") 2521=item $player_object->may ("access")
2234 2522
2235Returns wether the given player is authorized to access resource "access" 2523Returns wether the given player is authorized to access resource "access"
2314 # use -1 or undef as default coordinates, not 0, 0 2602 # use -1 or undef as default coordinates, not 0, 0
2315 ($x, $y) = ($map->enter_x, $map->enter_y) 2603 ($x, $y) = ($map->enter_x, $map->enter_y)
2316 if $x <=0 && $y <= 0; 2604 if $x <=0 && $y <= 0;
2317 2605
2318 $map->load; 2606 $map->load;
2319 $map->load_diag; 2607 $map->load_neighbours;
2320 2608
2321 return unless $self->contr->active; 2609 return unless $self->contr->active;
2322 $self->activate_recursive; 2610 $self->activate_recursive;
2323 2611
2324 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2612 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2331her, loading and preparing them map, calling the provided $check callback 2619her, loading and preparing them map, calling the provided $check callback
2332that has to return the map if sucecssful, and then unfreezes the player on 2620that has to return the map if sucecssful, and then unfreezes the player on
2333the new (success) or old (failed) map position. In either case, $done will 2621the new (success) or old (failed) map position. In either case, $done will
2334be called at the end of this process. 2622be called at the end of this process.
2335 2623
2624Note that $check will be called with a potentially non-loaded map, so if
2625it needs a loaded map it has to call C<< ->load >>.
2626
2336=cut 2627=cut
2337 2628
2338our $GOTOGEN; 2629our $GOTOGEN;
2339 2630
2340sub cf::object::player::goto { 2631sub cf::object::player::goto {
2344 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2635 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2345 2636
2346 $self->enter_link; 2637 $self->enter_link;
2347 2638
2348 (async { 2639 (async {
2640 $Coro::current->{desc} = "player::goto $path $x $y";
2641
2642 # *tag paths override both path and x|y
2643 if ($path =~ /^\*(.*)$/) {
2644 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2645 my $ob = $obs[rand @obs];
2646
2647 # see if we actually can go there
2648 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2649 $ob = $obs[rand @obs];
2650 } else {
2651 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2652 }
2653 # else put us there anyways for now #d#
2654
2655 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2656 } else {
2657 ($path, $x, $y) = (undef, undef, undef);
2658 }
2659 }
2660
2349 my $map = eval { 2661 my $map = eval {
2350 my $map = cf::map::find $path; 2662 my $map = defined $path ? cf::map::find $path : undef;
2351 2663
2352 if ($map) { 2664 if ($map) {
2353 $map = $map->customise_for ($self); 2665 $map = $map->customise_for ($self);
2354 $map = $check->($map) if $check && $map; 2666 $map = $check->($map) if $check && $map;
2355 } else { 2667 } else {
2356 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2668 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2357 } 2669 }
2358 2670
2359 $map 2671 $map
2360 }; 2672 };
2361 2673
2397} 2709}
2398 2710
2399sub prepare_random_map { 2711sub prepare_random_map {
2400 my ($exit) = @_; 2712 my ($exit) = @_;
2401 2713
2402 my $guard = cf::lock_acquire "exit_prepare:$exit";
2403
2404 # all this does is basically replace the /! path by 2714 # all this does is basically replace the /! path by
2405 # a new random map path (?random/...) with a seed 2715 # a new random map path (?random/...) with a seed
2406 # that depends on the exit object 2716 # that depends on the exit object
2407 2717
2408 my $rmp = parse_random_map_params $exit->msg; 2718 my $rmp = parse_random_map_params $exit->msg;
2410 if ($exit->map) { 2720 if ($exit->map) {
2411 $rmp->{region} = $exit->region->name; 2721 $rmp->{region} = $exit->region->name;
2412 $rmp->{origin_map} = $exit->map->path; 2722 $rmp->{origin_map} = $exit->map->path;
2413 $rmp->{origin_x} = $exit->x; 2723 $rmp->{origin_x} = $exit->x;
2414 $rmp->{origin_y} = $exit->y; 2724 $rmp->{origin_y} = $exit->y;
2725
2726 $exit->map->touch;
2415 } 2727 }
2416 2728
2417 $rmp->{random_seed} ||= $exit->random_seed; 2729 $rmp->{random_seed} ||= $exit->random_seed;
2418 2730
2419 my $data = cf::to_json $rmp; 2731 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2420 my $md5 = Digest::MD5::md5_hex $data; 2732 my $md5 = Digest::MD5::md5_hex $data;
2421 my $meta = "$RANDOMDIR/$md5.meta"; 2733 my $meta = "$RANDOMDIR/$md5.meta";
2422 2734
2423 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2735 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2424 aio_write $fh, 0, (length $data), $data, 0; 2736 aio_write $fh, 0, (length $data), $data, 0;
2425 undef $fh; 2737 undef $fh;
2426 aio_rename "$meta~", $meta; 2738 aio_rename "$meta~", $meta;
2427 2739
2740 my $slaying = "?random/$md5";
2741
2742 if ($exit->valid) {
2428 $exit->slaying ("?random/$md5"); 2743 $exit->slaying ("?random/$md5");
2429 $exit->msg (undef); 2744 $exit->msg (undef);
2745 }
2430 } 2746 }
2431} 2747}
2432 2748
2433sub cf::object::player::enter_exit { 2749sub cf::object::player::enter_exit {
2434 my ($self, $exit) = @_; 2750 my ($self, $exit) = @_;
2435 2751
2436 return unless $self->type == cf::PLAYER; 2752 return unless $self->type == cf::PLAYER;
2437 2753
2438 if ($exit->slaying eq "/!") {
2439 #TODO: this should de-fi-ni-te-ly not be a sync-job
2440 # the problem is that $exit might not survive long enough
2441 # so it needs to be done right now, right here
2442 cf::sync_job { prepare_random_map $exit };
2443 }
2444
2445 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2446 my $hp = $exit->stats->hp;
2447 my $sp = $exit->stats->sp;
2448
2449 $self->enter_link; 2754 $self->enter_link;
2450 2755
2451 # if exit is damned, update players death & WoR home-position
2452 $self->contr->savebed ($slaying, $hp, $sp)
2453 if $exit->flag (FLAG_DAMNED);
2454
2455 (async { 2756 (async {
2456 $self->deactivate_recursive; # just to be sure 2757 $Coro::current->{desc} = "enter_exit";
2758
2457 unless (eval { 2759 unless (eval {
2760 $self->deactivate_recursive; # just to be sure
2761
2762 # random map handling
2763 {
2764 my $guard = cf::lock_acquire "exit_prepare:$exit";
2765
2766 prepare_random_map $exit
2767 if $exit->slaying eq "/!";
2768 }
2769
2770 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2771 my $x = $exit->stats->hp;
2772 my $y = $exit->stats->sp;
2773
2458 $self->goto ($slaying, $hp, $sp); 2774 $self->goto ($map, $x, $y);
2459 2775
2776 # if exit is damned, update players death & WoR home-position
2777 $self->contr->savebed ($map, $x, $y)
2778 if $exit->flag (cf::FLAG_DAMNED);
2779
2460 1; 2780 1
2461 }) { 2781 }) {
2462 $self->message ("Something went wrong deep within the crossfire server. " 2782 $self->message ("Something went wrong deep within the crossfire server. "
2463 . "I'll try to bring you back to the map you were before. " 2783 . "I'll try to bring you back to the map you were before. "
2464 . "Please report this to the dungeon master!", 2784 . "Please report this to the dungeon master!",
2465 cf::NDI_UNIQUE | cf::NDI_RED); 2785 cf::NDI_UNIQUE | cf::NDI_RED);
2495the message, with C<log> being the default. If C<$color> is negative, suppress 2815the message, with C<log> being the default. If C<$color> is negative, suppress
2496the message unless the client supports the msg packet. 2816the message unless the client supports the msg packet.
2497 2817
2498=cut 2818=cut
2499 2819
2820# non-persistent channels (usually the info channel)
2821our %CHANNEL = (
2822 "c/identify" => {
2823 id => "infobox",
2824 title => "Identify",
2825 reply => undef,
2826 tooltip => "Items recently identified",
2827 },
2828 "c/examine" => {
2829 id => "infobox",
2830 title => "Examine",
2831 reply => undef,
2832 tooltip => "Signs and other items you examined",
2833 },
2834 "c/book" => {
2835 id => "infobox",
2836 title => "Book",
2837 reply => undef,
2838 tooltip => "The contents of a note or book",
2839 },
2840 "c/lookat" => {
2841 id => "infobox",
2842 title => "Look",
2843 reply => undef,
2844 tooltip => "What you saw there",
2845 },
2846 "c/who" => {
2847 id => "infobox",
2848 title => "Players",
2849 reply => undef,
2850 tooltip => "Shows players who are currently online",
2851 },
2852 "c/body" => {
2853 id => "infobox",
2854 title => "Body Parts",
2855 reply => undef,
2856 tooltip => "Shows which body parts you posess and are available",
2857 },
2858 "c/uptime" => {
2859 id => "infobox",
2860 title => "Uptime",
2861 reply => undef,
2862 tooltip => "How long the server has been running since last restart",
2863 },
2864 "c/mapinfo" => {
2865 id => "infobox",
2866 title => "Map Info",
2867 reply => undef,
2868 tooltip => "Information related to the maps",
2869 },
2870 "c/party" => {
2871 id => "party",
2872 title => "Party",
2873 reply => "gsay ",
2874 tooltip => "Messages and chat related to your party",
2875 },
2876);
2877
2500sub cf::client::send_msg { 2878sub cf::client::send_msg {
2501 my ($self, $channel, $msg, $color, @extra) = @_; 2879 my ($self, $channel, $msg, $color, @extra) = @_;
2502 2880
2503 $msg = $self->pl->expand_cfpod ($msg); 2881 $msg = $self->pl->expand_cfpod ($msg);
2504 2882
2505 $color &= ~cf::NDI_UNIQUE; # just in case... 2883 $color &= cf::NDI_CLIENT_MASK; # just in case...
2506 2884
2885 # check predefined channels, for the benefit of C
2886 if ($CHANNEL{$channel}) {
2887 $channel = $CHANNEL{$channel};
2888
2889 $self->ext_msg (channel_info => $channel)
2890 if $self->can_msg;
2891
2892 $channel = $channel->{id};
2893
2507 if (ref $channel) { 2894 } elsif (ref $channel) {
2508 # send meta info to client, if not yet sent 2895 # send meta info to client, if not yet sent
2509 unless (exists $self->{channel}{$channel->{id}}) { 2896 unless (exists $self->{channel}{$channel->{id}}) {
2510 $self->{channel}{$channel->{id}} = $channel; 2897 $self->{channel}{$channel->{id}} = $channel;
2511 $self->ext_event (channel_info => %$channel); 2898 $self->ext_msg (channel_info => $channel)
2899 if $self->can_msg;
2512 } 2900 }
2513 2901
2514 $channel = $channel->{id}; 2902 $channel = $channel->{id};
2515 } 2903 }
2516 2904
2517 return unless @extra || length $msg; 2905 return unless @extra || length $msg;
2518 2906
2519 if ($self->can_msg) { 2907 if ($self->can_msg) {
2908 # default colour, mask it out
2909 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2910 if $color & cf::NDI_DEF;
2911
2520 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $channel, $msg, @extra])); 2912 $self->send_packet ("msg " . $self->{json_coder}->encode (
2913 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2521 } else { 2914 } else {
2522 # replace some tags by gcfclient-compatible ones
2523 for ($msg) {
2524 1 while
2525 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2526 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2527 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2528 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2529 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2530 }
2531
2532 if ($color >= 0) { 2915 if ($color >= 0) {
2916 # replace some tags by gcfclient-compatible ones
2917 for ($msg) {
2918 1 while
2919 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2920 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2921 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2922 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2923 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2924 }
2925
2926 $color &= cf::NDI_COLOR_MASK;
2927
2928 utf8::encode $msg;
2929
2533 if (0 && $msg =~ /\[/) { 2930 if (0 && $msg =~ /\[/) {
2931 # COMMAND/INFO
2534 $self->send_packet ("drawextinfo $color 4 0 $msg") 2932 $self->send_packet ("drawextinfo $color 10 8 $msg")
2535 } else { 2933 } else {
2536 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g; 2934 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2537 $self->send_packet ("drawinfo $color $msg") 2935 $self->send_packet ("drawinfo $color $msg")
2538 } 2936 }
2539 } 2937 }
2540 } 2938 }
2541} 2939}
2542 2940
2543=item $client->ext_event ($type, %msg) 2941=item $client->ext_msg ($type, @msg)
2544 2942
2545Sends an ext event to the client. 2943Sends an ext event to the client.
2546 2944
2547=cut 2945=cut
2548 2946
2549sub cf::client::ext_event($$%) { 2947sub cf::client::ext_msg($$@) {
2550 my ($self, $type, %msg) = @_; 2948 my ($self, $type, @msg) = @_;
2551 2949
2552 return unless $self->extcmd; 2950 if ($self->extcmd == 2) {
2553 2951 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2952 } elsif ($self->extcmd == 1) { # TODO: remove
2554 $msg{msgtype} = "event_$type"; 2953 push @msg, msgtype => "event_$type";
2555 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg)); 2954 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2955 }
2956}
2957
2958=item $client->ext_reply ($msgid, @msg)
2959
2960Sends an ext reply to the client.
2961
2962=cut
2963
2964sub cf::client::ext_reply($$@) {
2965 my ($self, $id, @msg) = @_;
2966
2967 if ($self->extcmd == 2) {
2968 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2969 } elsif ($self->extcmd == 1) {
2970 #TODO: version 1, remove
2971 unshift @msg, msgtype => "reply", msgid => $id;
2972 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2973 }
2556} 2974}
2557 2975
2558=item $success = $client->query ($flags, "text", \&cb) 2976=item $success = $client->query ($flags, "text", \&cb)
2559 2977
2560Queues a query to the client, calling the given callback with 2978Queues a query to the client, calling the given callback with
2615 my ($ns, $buf) = @_; 3033 my ($ns, $buf) = @_;
2616 3034
2617 my $msg = eval { $ns->{json_coder}->decode ($buf) }; 3035 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2618 3036
2619 if (ref $msg) { 3037 if (ref $msg) {
3038 my ($type, $reply, @payload) =
3039 "ARRAY" eq ref $msg
3040 ? @$msg
3041 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3042
3043 my @reply;
3044
2620 if (my $cb = $EXTICMD{$msg->{msgtype}}) { 3045 if (my $cb = $EXTICMD{$type}) {
2621 if (my %reply = $cb->($ns, $msg)) { 3046 @reply = $cb->($ns, @payload);
2622 $reply{msgid} = $msg->{msgid};
2623 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2624 }
2625 } 3047 }
3048
3049 $ns->ext_reply ($reply, @reply)
3050 if $reply;
3051
2626 } else { 3052 } else {
2627 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3053 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2628 } 3054 }
2629 3055
2630 cf::override; 3056 cf::override;
2677our $safe = new Safe "safe"; 3103our $safe = new Safe "safe";
2678our $safe_hole = new Safe::Hole; 3104our $safe_hole = new Safe::Hole;
2679 3105
2680$SIG{FPE} = 'IGNORE'; 3106$SIG{FPE} = 'IGNORE';
2681 3107
2682$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3108$safe->permit_only (Opcode::opset qw(
3109 :base_core :base_mem :base_orig :base_math
3110 grepstart grepwhile mapstart mapwhile
3111 sort time
3112));
2683 3113
2684# here we export the classes and methods available to script code 3114# here we export the classes and methods available to script code
2685 3115
2686=pod 3116=pod
2687 3117
2688The following functions and methods are available within a safe environment: 3118The following functions and methods are available within a safe environment:
2689 3119
2690 cf::object 3120 cf::object
2691 contr pay_amount pay_player map x y force_find force_add 3121 contr pay_amount pay_player map x y force_find force_add destroy
2692 insert remove 3122 insert remove name archname title slaying race decrease split
2693 3123
2694 cf::object::player 3124 cf::object::player
2695 player 3125 player
2696 3126
2697 cf::player 3127 cf::player
2702 3132
2703=cut 3133=cut
2704 3134
2705for ( 3135for (
2706 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3136 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2707 insert remove)], 3137 insert remove inv nrof name archname title slaying race
3138 decrease split destroy change_exp)],
2708 ["cf::object::player" => qw(player)], 3139 ["cf::object::player" => qw(player)],
2709 ["cf::player" => qw(peaceful)], 3140 ["cf::player" => qw(peaceful)],
2710 ["cf::map" => qw(trigger)], 3141 ["cf::map" => qw(trigger)],
2711) { 3142) {
2712 no strict 'refs'; 3143 no strict 'refs';
2788# the server's init and main functions 3219# the server's init and main functions
2789 3220
2790sub load_facedata($) { 3221sub load_facedata($) {
2791 my ($path) = @_; 3222 my ($path) = @_;
2792 3223
3224 # HACK to clear player env face cache, we need some signal framework
3225 # for this (global event?)
3226 %ext::player_env::MUSIC_FACE_CACHE = ();
3227
3228 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3229
2793 warn "loading facedata from $path\n"; 3230 warn "loading facedata from $path\n";
2794 3231
2795 my $facedata; 3232 my $facedata;
2796 0 < aio_load $path, $facedata 3233 0 < aio_load $path, $facedata
2797 or die "$path: $!"; 3234 or die "$path: $!";
2799 $facedata = Coro::Storable::thaw $facedata; 3236 $facedata = Coro::Storable::thaw $facedata;
2800 3237
2801 $facedata->{version} == 2 3238 $facedata->{version} == 2
2802 or cf::cleanup "$path: version mismatch, cannot proceed."; 3239 or cf::cleanup "$path: version mismatch, cannot proceed.";
2803 3240
3241 # patch in the exptable
3242 $facedata->{resource}{"res/exp_table"} = {
3243 type => FT_RSRC,
3244 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3245 };
3246 cf::cede_to_tick;
3247
2804 { 3248 {
2805 my $faces = $facedata->{faceinfo}; 3249 my $faces = $facedata->{faceinfo};
2806 3250
2807 while (my ($face, $info) = each %$faces) { 3251 while (my ($face, $info) = each %$faces) {
2808 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3252 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3253
2809 cf::face::set_visibility $idx, $info->{visibility}; 3254 cf::face::set_visibility $idx, $info->{visibility};
2810 cf::face::set_magicmap $idx, $info->{magicmap}; 3255 cf::face::set_magicmap $idx, $info->{magicmap};
2811 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3256 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2812 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3257 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2813 3258
2814 cf::cede_to_tick; 3259 cf::cede_to_tick;
2815 } 3260 }
2816 3261
2817 while (my ($face, $info) = each %$faces) { 3262 while (my ($face, $info) = each %$faces) {
2818 next unless $info->{smooth}; 3263 next unless $info->{smooth};
3264
2819 my $idx = cf::face::find $face 3265 my $idx = cf::face::find $face
2820 or next; 3266 or next;
3267
2821 if (my $smooth = cf::face::find $info->{smooth}) { 3268 if (my $smooth = cf::face::find $info->{smooth}) {
2822 cf::face::set_smooth $idx, $smooth; 3269 cf::face::set_smooth $idx, $smooth;
2823 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3270 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2824 } else { 3271 } else {
2825 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3272 warn "smooth face '$info->{smooth}' not found for face '$face'";
2842 3289
2843 { 3290 {
2844 # TODO: for gcfclient pleasure, we should give resources 3291 # TODO: for gcfclient pleasure, we should give resources
2845 # that gcfclient doesn't grok a >10000 face index. 3292 # that gcfclient doesn't grok a >10000 face index.
2846 my $res = $facedata->{resource}; 3293 my $res = $facedata->{resource};
2847 my $enc = JSON::XS->new->utf8->canonical;
2848 3294
2849 while (my ($name, $info) = each %$res) { 3295 while (my ($name, $info) = each %$res) {
2850 my $meta = $enc->encode ({ 3296 if (defined $info->{type}) {
2851 name => $name,
2852 type => $info->{type},
2853 copyright => $info->{copyright}, #TODO#
2854 });
2855
2856 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3297 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3298 my $data;
2857 3299
2858 if ($name =~ /\.jpg$/) { 3300 if ($info->{type} & 1) {
2859 cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack 3301 # prepend meta info
2860 cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack 3302
3303 my $meta = $enc->encode ({
3304 name => $name,
3305 %{ $info->{meta} || {} },
3306 });
3307
3308 $data = pack "(w/a*)*", $meta, $info->{data};
3309 } else {
3310 $data = $info->{data};
3311 }
3312
3313 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3314 cf::face::set_type $idx, $info->{type};
2861 } else { 3315 } else {
2862 my $data = pack "(w/a*)*", $meta, $info->{data}; 3316 $RESOURCE{$name} = $info;
2863 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2864
2865 cf::face::set_type $idx, 1;
2866 cf::face::set_data $idx, 0, $data, $chk;
2867 } 3317 }
2868 3318
2869 cf::cede_to_tick; 3319 cf::cede_to_tick;
2870 } 3320 }
2871 } 3321 }
2872 3322
3323 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3324
2873 1 3325 1
2874} 3326}
2875 3327
3328cf::global->attach (on_resource_update => sub {
3329 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3330 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3331
3332 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3333 my $sound = $soundconf->{compat}[$_]
3334 or next;
3335
3336 my $face = cf::face::find "sound/$sound->[1]";
3337 cf::sound::set $sound->[0] => $face;
3338 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3339 }
3340
3341 while (my ($k, $v) = each %{$soundconf->{event}}) {
3342 my $face = cf::face::find "sound/$v";
3343 cf::sound::set $k => $face;
3344 }
3345 }
3346});
3347
3348register_exticmd fx_want => sub {
3349 my ($ns, $want) = @_;
3350
3351 while (my ($k, $v) = each %$want) {
3352 $ns->fx_want ($k, $v);
3353 }
3354};
3355
3356sub load_resource_file($) {
3357 my $guard = lock_acquire "load_resource_file";
3358
3359 my $status = load_resource_file_ $_[0];
3360 get_slot 0.1, 100;
3361 cf::arch::commit_load;
3362
3363 $status
3364}
3365
2876sub reload_regions { 3366sub reload_regions {
3367 # HACK to clear player env face cache, we need some signal framework
3368 # for this (global event?)
3369 %ext::player_env::MUSIC_FACE_CACHE = ();
3370
2877 load_resource_file "$MAPDIR/regions" 3371 load_resource_file "$MAPDIR/regions"
2878 or die "unable to load regions file\n"; 3372 or die "unable to load regions file\n";
2879 3373
2880 for (cf::region::list) { 3374 for (cf::region::list) {
2881 $_->{match} = qr/$_->{match}/ 3375 $_->{match} = qr/$_->{match}/
2889} 3383}
2890 3384
2891sub reload_archetypes { 3385sub reload_archetypes {
2892 load_resource_file "$DATADIR/archetypes" 3386 load_resource_file "$DATADIR/archetypes"
2893 or die "unable to load archetypes\n"; 3387 or die "unable to load archetypes\n";
2894 #d# NEED to laod twice to resolve forward references
2895 # this really needs to be done in an extra post-pass
2896 # (which needs to be synchronous, so solve it differently)
2897 load_resource_file "$DATADIR/archetypes"
2898 or die "unable to load archetypes\n";
2899} 3388}
2900 3389
2901sub reload_treasures { 3390sub reload_treasures {
2902 load_resource_file "$DATADIR/treasures" 3391 load_resource_file "$DATADIR/treasures"
2903 or die "unable to load treasurelists\n"; 3392 or die "unable to load treasurelists\n";
2904} 3393}
2905 3394
2906sub reload_resources { 3395sub reload_resources {
2907 warn "reloading resource files...\n"; 3396 warn "reloading resource files...\n";
2908 3397
3398 reload_facedata;
3399 reload_archetypes;
2909 reload_regions; 3400 reload_regions;
2910 reload_facedata;
2911 #reload_archetypes;#d#
2912 reload_archetypes;
2913 reload_treasures; 3401 reload_treasures;
2914 3402
2915 warn "finished reloading resource files\n"; 3403 warn "finished reloading resource files\n";
2916} 3404}
2917 3405
2918sub init { 3406sub init {
3407 my $guard = freeze_mainloop;
3408
3409 evthread_start IO::AIO::poll_fileno;
3410
2919 reload_resources; 3411 reload_resources;
2920} 3412}
2921 3413
2922sub cfg_load { 3414sub reload_config {
2923 open my $fh, "<:utf8", "$CONFDIR/config" 3415 open my $fh, "<:utf8", "$CONFDIR/config"
2924 or return; 3416 or return;
2925 3417
2926 local $/; 3418 local $/;
2927 *CFG = YAML::Syck::Load <$fh>; 3419 *CFG = YAML::Load <$fh>;
2928 3420
2929 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3421 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2930 3422
2931 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3423 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2932 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3424 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2943sub main { 3435sub main {
2944 # we must not ever block the main coroutine 3436 # we must not ever block the main coroutine
2945 local $Coro::idle = sub { 3437 local $Coro::idle = sub {
2946 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3438 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2947 (async { 3439 (async {
2948 Event::one_event; 3440 $Coro::current->{desc} = "IDLE BUG HANDLER";
3441 EV::loop EV::LOOP_ONESHOT;
2949 })->prio (Coro::PRIO_MAX); 3442 })->prio (Coro::PRIO_MAX);
2950 }; 3443 };
2951 3444
2952 cfg_load; 3445 {
3446 my $guard = freeze_mainloop;
3447 reload_config;
2953 db_init; 3448 db_init;
2954 load_extensions; 3449 load_extensions;
2955 3450
2956 $TICK_WATCHER->start; 3451 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3452 }
3453
2957 Event::loop; 3454 EV::loop;
2958} 3455}
2959 3456
2960############################################################################# 3457#############################################################################
2961# initialisation and cleanup 3458# initialisation and cleanup
2962 3459
2963# install some emergency cleanup handlers 3460# install some emergency cleanup handlers
2964BEGIN { 3461BEGIN {
3462 our %SIGWATCHER = ();
2965 for my $signal (qw(INT HUP TERM)) { 3463 for my $signal (qw(INT HUP TERM)) {
2966 Event->signal ( 3464 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2967 reentrant => 0,
2968 data => WF_AUTOCANCEL,
2969 signal => $signal,
2970 prio => 0,
2971 cb => sub {
2972 cf::cleanup "SIG$signal"; 3465 cf::cleanup "SIG$signal";
2973 },
2974 ); 3466 };
2975 } 3467 }
2976} 3468}
2977 3469
2978sub write_runtime { 3470sub write_runtime_sync {
2979 my $runtime = "$LOCALDIR/runtime"; 3471 my $runtime = "$LOCALDIR/runtime";
2980 3472
2981 # first touch the runtime file to show we are still running: 3473 # first touch the runtime file to show we are still running:
2982 # the fsync below can take a very very long time. 3474 # the fsync below can take a very very long time.
2983 3475
3009 and return; 3501 and return;
3010 3502
3011 warn "runtime file written.\n"; 3503 warn "runtime file written.\n";
3012 3504
3013 1 3505 1
3506}
3507
3508our $uuid_lock;
3509our $uuid_skip;
3510
3511sub write_uuid_sync($) {
3512 $uuid_skip ||= $_[0];
3513
3514 return if $uuid_lock;
3515 local $uuid_lock = 1;
3516
3517 my $uuid = "$LOCALDIR/uuid";
3518
3519 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3520 or return;
3521
3522 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3523 $uuid_skip = 0;
3524
3525 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3526 and return;
3527
3528 # always fsync - this file is important
3529 aio_fsync $fh
3530 and return;
3531
3532 close $fh
3533 or return;
3534
3535 aio_rename "$uuid~", $uuid
3536 and return;
3537
3538 warn "uuid file written ($value).\n";
3539
3540 1
3541
3542}
3543
3544sub write_uuid($$) {
3545 my ($skip, $sync) = @_;
3546
3547 $sync ? write_uuid_sync $skip
3548 : async { write_uuid_sync $skip };
3014} 3549}
3015 3550
3016sub emergency_save() { 3551sub emergency_save() {
3017 my $freeze_guard = cf::freeze_mainloop; 3552 my $freeze_guard = cf::freeze_mainloop;
3018 3553
3024 # and maps saved/destroyed asynchronously. 3559 # and maps saved/destroyed asynchronously.
3025 warn "begin emergency player save\n"; 3560 warn "begin emergency player save\n";
3026 for my $login (keys %cf::PLAYER) { 3561 for my $login (keys %cf::PLAYER) {
3027 my $pl = $cf::PLAYER{$login} or next; 3562 my $pl = $cf::PLAYER{$login} or next;
3028 $pl->valid or next; 3563 $pl->valid or next;
3564 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3029 $pl->save; 3565 $pl->save;
3030 } 3566 }
3031 warn "end emergency player save\n"; 3567 warn "end emergency player save\n";
3032 3568
3033 warn "begin emergency map save\n"; 3569 warn "begin emergency map save\n";
3039 warn "end emergency map save\n"; 3575 warn "end emergency map save\n";
3040 3576
3041 warn "begin emergency database checkpoint\n"; 3577 warn "begin emergency database checkpoint\n";
3042 BDB::db_env_txn_checkpoint $DB_ENV; 3578 BDB::db_env_txn_checkpoint $DB_ENV;
3043 warn "end emergency database checkpoint\n"; 3579 warn "end emergency database checkpoint\n";
3580
3581 warn "begin write uuid\n";
3582 write_uuid_sync 1;
3583 warn "end write uuid\n";
3044 }; 3584 };
3045 3585
3046 warn "leave emergency perl save\n"; 3586 warn "leave emergency perl save\n";
3047} 3587}
3048 3588
3050 my ($make_core) = @_; 3590 my ($make_core) = @_;
3051 3591
3052 warn Carp::longmess "post_cleanup backtrace" 3592 warn Carp::longmess "post_cleanup backtrace"
3053 if $make_core; 3593 if $make_core;
3054} 3594}
3595
3596# a safer delete_package, copied from Symbol
3597sub clear_package($) {
3598 my $pkg = shift;
3599
3600 # expand to full symbol table name if needed
3601 unless ($pkg =~ /^main::.*::$/) {
3602 $pkg = "main$pkg" if $pkg =~ /^::/;
3603 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3604 $pkg .= '::' unless $pkg =~ /::$/;
3605 }
3606
3607 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3608 my $stem_symtab = *{$stem}{HASH};
3609
3610 defined $stem_symtab and exists $stem_symtab->{$leaf}
3611 or return;
3612
3613 # clear all symbols
3614 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3615 for my $name (keys %$leaf_symtab) {
3616 _gv_clear *{"$pkg$name"};
3617# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3618 }
3619 warn "cleared package #$pkg\n";#d#
3620}
3621
3622our $RELOAD; # how many times to reload
3055 3623
3056sub do_reload_perl() { 3624sub do_reload_perl() {
3057 # can/must only be called in main 3625 # can/must only be called in main
3058 if ($Coro::current != $Coro::main) { 3626 if ($Coro::current != $Coro::main) {
3059 warn "can only reload from main coroutine"; 3627 warn "can only reload from main coroutine";
3060 return; 3628 return;
3061 } 3629 }
3062 3630
3631 return if $RELOAD++;
3632
3633 while ($RELOAD) {
3063 warn "reloading..."; 3634 warn "reloading...";
3064 3635
3065 warn "entering sync_job"; 3636 warn "entering sync_job";
3066 3637
3067 cf::sync_job { 3638 cf::sync_job {
3068 cf::write_runtime; # external watchdog should not bark 3639 cf::write_runtime_sync; # external watchdog should not bark
3069 cf::emergency_save; 3640 cf::emergency_save;
3070 cf::write_runtime; # external watchdog should not bark 3641 cf::write_runtime_sync; # external watchdog should not bark
3071 3642
3072 warn "syncing database to disk"; 3643 warn "syncing database to disk";
3073 BDB::db_env_txn_checkpoint $DB_ENV; 3644 BDB::db_env_txn_checkpoint $DB_ENV;
3074 3645
3075 # if anything goes wrong in here, we should simply crash as we already saved 3646 # if anything goes wrong in here, we should simply crash as we already saved
3076 3647
3077 warn "cancelling all WF_AUTOCANCEL watchers";
3078 for (Event::all_watchers) {
3079 $_->cancel if $_->data & WF_AUTOCANCEL;
3080 }
3081
3082 warn "flushing outstanding aio requests"; 3648 warn "flushing outstanding aio requests";
3083 for (;;) {
3084 BDB::flush;
3085 IO::AIO::flush;
3086 Coro::cede;
3087 last unless IO::AIO::nreqs || BDB::nreqs; 3649 while (IO::AIO::nreqs || BDB::nreqs) {
3088 warn "iterate..."; 3650 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3089 }
3090
3091 ++$RELOAD;
3092
3093 warn "cancelling all extension coros";
3094 $_->cancel for values %EXT_CORO;
3095 %EXT_CORO = ();
3096
3097 warn "removing commands";
3098 %COMMAND = ();
3099
3100 warn "removing ext/exti commands";
3101 %EXTCMD = ();
3102 %EXTICMD = ();
3103
3104 warn "unloading/nuking all extensions";
3105 for my $pkg (@EXTS) {
3106 warn "... unloading $pkg";
3107
3108 if (my $cb = $pkg->can ("unload")) {
3109 eval {
3110 $cb->($pkg);
3111 1
3112 } or warn "$pkg unloaded, but with errors: $@";
3113 } 3651 }
3114 3652
3115 warn "... nuking $pkg"; 3653 warn "cancelling all extension coros";
3116 Symbol::delete_package $pkg; 3654 $_->cancel for values %EXT_CORO;
3117 } 3655 %EXT_CORO = ();
3118 3656
3119 warn "unloading all perl modules loaded from $LIBDIR"; 3657 warn "removing commands";
3120 while (my ($k, $v) = each %INC) { 3658 %COMMAND = ();
3121 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3122 3659
3660 warn "removing ext/exti commands";
3661 %EXTCMD = ();
3662 %EXTICMD = ();
3663
3664 warn "unloading/nuking all extensions";
3665 for my $pkg (@EXTS) {
3123 warn "... unloading $k"; 3666 warn "... unloading $pkg";
3124 delete $INC{$k};
3125 3667
3126 $k =~ s/\.pm$//;
3127 $k =~ s/\//::/g;
3128
3129 if (my $cb = $k->can ("unload_module")) { 3668 if (my $cb = $pkg->can ("unload")) {
3669 eval {
3130 $cb->(); 3670 $cb->($pkg);
3671 1
3672 } or warn "$pkg unloaded, but with errors: $@";
3673 }
3674
3675 warn "... clearing $pkg";
3676 clear_package $pkg;
3131 } 3677 }
3132 3678
3133 Symbol::delete_package $k; 3679 warn "unloading all perl modules loaded from $LIBDIR";
3680 while (my ($k, $v) = each %INC) {
3681 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3682
3683 warn "... unloading $k";
3684 delete $INC{$k};
3685
3686 $k =~ s/\.pm$//;
3687 $k =~ s/\//::/g;
3688
3689 if (my $cb = $k->can ("unload_module")) {
3690 $cb->();
3691 }
3692
3693 clear_package $k;
3134 } 3694 }
3135 3695
3136 warn "getting rid of safe::, as good as possible"; 3696 warn "getting rid of safe::, as good as possible";
3137 Symbol::delete_package "safe::$_" 3697 clear_package "safe::$_"
3138 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3698 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3139 3699
3140 warn "unloading cf.pm \"a bit\""; 3700 warn "unloading cf.pm \"a bit\"";
3141 delete $INC{"cf.pm"}; 3701 delete $INC{"cf.pm"};
3142 delete $INC{"cf/pod.pm"}; 3702 delete $INC{"cf/pod.pm"};
3143 3703
3144 # don't, removes xs symbols, too, 3704 # don't, removes xs symbols, too,
3145 # and global variables created in xs 3705 # and global variables created in xs
3146 #Symbol::delete_package __PACKAGE__; 3706 #clear_package __PACKAGE__;
3147 3707
3148 warn "unload completed, starting to reload now"; 3708 warn "unload completed, starting to reload now";
3149 3709
3150 warn "reloading cf.pm"; 3710 warn "reloading cf.pm";
3151 require cf; 3711 require cf;
3152 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3712 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3153 3713
3154 warn "loading config and database again"; 3714 warn "loading config and database again";
3155 cf::cfg_load; 3715 cf::reload_config;
3156 3716
3157 warn "loading extensions"; 3717 warn "loading extensions";
3158 cf::load_extensions; 3718 cf::load_extensions;
3159 3719
3160 warn "reattaching attachments to objects/players"; 3720 warn "reattaching attachments to objects/players";
3161 _global_reattach; # objects, sockets 3721 _global_reattach; # objects, sockets
3162 warn "reattaching attachments to maps"; 3722 warn "reattaching attachments to maps";
3163 reattach $_ for values %MAP; 3723 reattach $_ for values %MAP;
3164 warn "reattaching attachments to players"; 3724 warn "reattaching attachments to players";
3165 reattach $_ for values %PLAYER; 3725 reattach $_ for values %PLAYER;
3166 3726
3167 warn "leaving sync_job"; 3727 warn "leaving sync_job";
3168 3728
3169 1 3729 1
3170 } or do { 3730 } or do {
3171 warn $@; 3731 warn $@;
3172 warn "error while reloading, exiting."; 3732 cf::cleanup "error while reloading, exiting.";
3173 exit 1;
3174 }; 3733 };
3175 3734
3176 warn "reloaded"; 3735 warn "reloaded";
3736 --$RELOAD;
3737 }
3177}; 3738};
3178 3739
3179our $RELOAD_WATCHER; # used only during reload 3740our $RELOAD_WATCHER; # used only during reload
3180 3741
3181sub reload_perl() { 3742sub reload_perl() {
3182 # doing reload synchronously and two reloads happen back-to-back, 3743 # doing reload synchronously and two reloads happen back-to-back,
3183 # coro crashes during coro_state_free->destroy here. 3744 # coro crashes during coro_state_free->destroy here.
3184 3745
3185 $RELOAD_WATCHER ||= Event->timer ( 3746 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3186 reentrant => 0,
3187 after => 0,
3188 data => WF_AUTOCANCEL,
3189 cb => sub {
3190 do_reload_perl; 3747 do_reload_perl;
3191 undef $RELOAD_WATCHER; 3748 undef $RELOAD_WATCHER;
3192 },
3193 ); 3749 };
3194} 3750}
3195 3751
3196register_command "reload" => sub { 3752register_command "reload" => sub {
3197 my ($who, $arg) = @_; 3753 my ($who, $arg) = @_;
3198 3754
3199 if ($who->flag (FLAG_WIZ)) { 3755 if ($who->flag (FLAG_WIZ)) {
3200 $who->message ("reloading server."); 3756 $who->message ("reloading server.");
3757 async {
3758 $Coro::current->{desc} = "perl_reload";
3201 async { reload_perl }; 3759 reload_perl;
3760 };
3202 } 3761 }
3203}; 3762};
3204 3763
3205unshift @INC, $LIBDIR; 3764unshift @INC, $LIBDIR;
3206 3765
3208 3767
3209our @WAIT_FOR_TICK; 3768our @WAIT_FOR_TICK;
3210our @WAIT_FOR_TICK_BEGIN; 3769our @WAIT_FOR_TICK_BEGIN;
3211 3770
3212sub wait_for_tick { 3771sub wait_for_tick {
3213 return unless $TICK_WATCHER->is_active;
3214 return if $Coro::current == $Coro::main; 3772 return if tick_inhibit || $Coro::current == $Coro::main;
3215 3773
3216 my $signal = new Coro::Signal; 3774 my $signal = new Coro::Signal;
3217 push @WAIT_FOR_TICK, $signal; 3775 push @WAIT_FOR_TICK, $signal;
3218 $signal->wait; 3776 $signal->wait;
3219} 3777}
3220 3778
3221sub wait_for_tick_begin { 3779sub wait_for_tick_begin {
3222 return unless $TICK_WATCHER->is_active;
3223 return if $Coro::current == $Coro::main; 3780 return if tick_inhibit || $Coro::current == $Coro::main;
3224 3781
3225 my $signal = new Coro::Signal; 3782 my $signal = new Coro::Signal;
3226 push @WAIT_FOR_TICK_BEGIN, $signal; 3783 push @WAIT_FOR_TICK_BEGIN, $signal;
3227 $signal->wait; 3784 $signal->wait;
3228} 3785}
3229 3786
3230 my $min = 1e6;#d# 3787sub tick {
3231 my $avg = 10;
3232$TICK_WATCHER = Event->timer (
3233 reentrant => 0,
3234 parked => 1,
3235 prio => 0,
3236 at => $NEXT_TICK || $TICK,
3237 data => WF_AUTOCANCEL,
3238 cb => sub {
3239 if ($Coro::current != $Coro::main) { 3788 if ($Coro::current != $Coro::main) {
3240 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3789 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3241 unless ++$bug_warning > 10; 3790 unless ++$bug_warning > 10;
3242 return; 3791 return;
3243 } 3792 }
3244 3793
3245 $NOW = $tick_start = Event::time;
3246
3247 cf::server_tick; # one server iteration 3794 cf::server_tick; # one server iteration
3248 3795
3249 0 && sync_job {#d# 3796 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3250 for(1..10) { 3797 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3251 my $t = Event::time; 3798 Coro::async_pool {
3252 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3799 $Coro::current->{desc} = "runtime saver";
3253 or die; 3800 write_runtime_sync
3254 3801 or warn "ERROR: unable to write runtime file: $!";
3255 $map->width (50);
3256 $map->height (50);
3257 $map->alloc;
3258 $map->_load_objects ("/tmp/x.map", 1);
3259 my $t = Event::time - $t;
3260
3261 #next unless $t < 0.0013;#d#
3262 if ($t < $min) {
3263 $min = $t;
3264 }
3265 $avg = $avg * 0.99 + $t * 0.01;
3266 }
3267 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3268 exit 0;
3269 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3270 }; 3802 };
3803 }
3271 3804
3272 $RUNTIME += $TICK;
3273 $NEXT_TICK += $TICK;
3274
3275 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3276 $NEXT_RUNTIME_WRITE = $NOW + 10;
3277 Coro::async_pool {
3278 write_runtime
3279 or warn "ERROR: unable to write runtime file: $!";
3280 };
3281 }
3282
3283# my $AFTER = Event::time;
3284# warn $AFTER - $NOW;#d#
3285
3286 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3805 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3287 $sig->send; 3806 $sig->send;
3288 } 3807 }
3289 while (my $sig = shift @WAIT_FOR_TICK) { 3808 while (my $sig = shift @WAIT_FOR_TICK) {
3290 $sig->send; 3809 $sig->send;
3291 } 3810 }
3292 3811
3293 $NOW = Event::time; 3812 $LOAD = ($NOW - $TICK_START) / $TICK;
3294
3295 # if we are delayed by four ticks or more, skip them all
3296 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3297
3298 $TICK_WATCHER->at ($NEXT_TICK);
3299 $TICK_WATCHER->start;
3300
3301 $LOAD = ($NOW - $tick_start) / $TICK;
3302 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3813 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3303 3814
3304 _post_tick; 3815 if (0) {
3305 3816 if ($NEXT_TICK) {
3306 3817 my $jitter = $TICK_START - $NEXT_TICK;
3818 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3819 warn "jitter $JITTER\n";#d#
3820 }
3307 }, 3821 }
3308); 3822}
3309 3823
3310{ 3824{
3311 BDB::max_poll_time $TICK * 0.1; 3825 # configure BDB
3312 $BDB_POLL_WATCHER = Event->io ( 3826
3313 reentrant => 0,
3314 fd => BDB::poll_fileno,
3315 poll => 'r',
3316 prio => 0,
3317 data => WF_AUTOCANCEL,
3318 cb => \&BDB::poll_cb,
3319 );
3320 BDB::min_parallel 8; 3827 BDB::min_parallel 8;
3321 3828 BDB::max_poll_reqs $TICK * 0.1;
3322 BDB::set_sync_prepare { 3829 $AnyEvent::BDB::WATCHER->priority (1);
3323 my $status;
3324 my $current = $Coro::current;
3325 (
3326 sub {
3327 $status = $!;
3328 $current->ready; undef $current;
3329 },
3330 sub {
3331 Coro::schedule while defined $current;
3332 $! = $status;
3333 },
3334 )
3335 };
3336 3830
3337 unless ($DB_ENV) { 3831 unless ($DB_ENV) {
3338 $DB_ENV = BDB::db_env_create; 3832 $DB_ENV = BDB::db_env_create;
3833 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3834 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3835 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3836 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3837 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3339 3838
3340 cf::sync_job { 3839 cf::sync_job {
3341 eval { 3840 eval {
3342 BDB::db_env_open 3841 BDB::db_env_open
3343 $DB_ENV, 3842 $DB_ENV,
3345 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3844 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3346 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3845 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3347 0666; 3846 0666;
3348 3847
3349 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3848 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3350
3351 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3352 $DB_ENV->set_lk_detect;
3353 }; 3849 };
3354 3850
3355 cf::cleanup "db_env_open(db): $@" if $@; 3851 cf::cleanup "db_env_open(db): $@" if $@;
3356 }; 3852 };
3357 } 3853 }
3854
3855 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3856 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3857 };
3858 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3859 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3860 };
3861 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3862 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3863 };
3358} 3864}
3359 3865
3360{ 3866{
3867 # configure IO::AIO
3868
3361 IO::AIO::min_parallel 8; 3869 IO::AIO::min_parallel 8;
3362
3363 undef $Coro::AIO::WATCHER;
3364 IO::AIO::max_poll_time $TICK * 0.1; 3870 IO::AIO::max_poll_time $TICK * 0.1;
3365 $AIO_POLL_WATCHER = Event->io ( 3871 undef $AnyEvent::AIO::WATCHER;
3366 reentrant => 0,
3367 data => WF_AUTOCANCEL,
3368 fd => IO::AIO::poll_fileno,
3369 poll => 'r',
3370 prio => 6,
3371 cb => \&IO::AIO::poll_cb,
3372 );
3373} 3872}
3374 3873
3375my $_log_backtrace; 3874my $_log_backtrace;
3376 3875
3377sub _log_backtrace { 3876sub _log_backtrace {
3381 3880
3382 # limit the # of concurrent backtraces 3881 # limit the # of concurrent backtraces
3383 if ($_log_backtrace < 2) { 3882 if ($_log_backtrace < 2) {
3384 ++$_log_backtrace; 3883 ++$_log_backtrace;
3385 async { 3884 async {
3885 $Coro::current->{desc} = "abt $msg";
3886
3386 my @bt = fork_call { 3887 my @bt = fork_call {
3387 @addr = map { sprintf "%x", $_ } @addr; 3888 @addr = map { sprintf "%x", $_ } @addr;
3388 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3889 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3389 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3890 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3390 or die "addr2line: $!"; 3891 or die "addr2line: $!";

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines