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.389 by root, Sat Oct 20 04:39:57 2007 UTC vs.
Revision 1.459 by root, Sat Dec 13 21:46:12 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 Event; 31use EV;
10use Opcode; 32use Opcode;
11use Safe; 33use Safe;
12use Safe::Hole; 34use Safe::Hole;
13use Storable (); 35use Storable ();
14 36
37use Guard ();
15use Coro 4.1 (); 38use Coro ();
16use Coro::State; 39use Coro::State;
17use Coro::Handle; 40use Coro::Handle;
41use Coro::EV;
18use Coro::Event; 42use Coro::AnyEvent;
19use Coro::Timer; 43use Coro::Timer;
20use Coro::Signal; 44use Coro::Signal;
21use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
22use Coro::AIO; 48use Coro::AIO;
49use Coro::BDB 1.6;
23use Coro::Storable; 50use Coro::Storable;
24use Coro::Util (); 51use Coro::Util ();
25 52
26use JSON::XS (); 53use JSON::XS 2.01 ();
27use BDB (); 54use BDB ();
28use Data::Dumper; 55use Data::Dumper;
29use Digest::MD5; 56use Digest::MD5;
30use Fcntl; 57use Fcntl;
31use YAML::Syck (); 58use YAML ();
32use IO::AIO 2.51 (); 59use IO::AIO ();
33use Time::HiRes; 60use Time::HiRes;
34use Compress::LZF; 61use Compress::LZF;
35use Digest::MD5 (); 62use Digest::MD5 ();
63
64AnyEvent::detect;
36 65
37# configure various modules to our taste 66# configure various modules to our taste
38# 67#
39$Storable::canonical = 1; # reduce rsync transfers 68$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 69Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
70
71$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
72
73# make sure c-lzf reinitialises itself
74Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 75Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
43$Event::Eval = 1; # no idea why this is required, but it is
44
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 76
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 77sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 78
52our %COMMAND = (); 79our %COMMAND = ();
53our %COMMAND_TIME = (); 80our %COMMAND_TIME = ();
… …
56our %EXTCMD = (); 83our %EXTCMD = ();
57our %EXTICMD = (); 84our %EXTICMD = ();
58our %EXT_CORO = (); # coroutines bound to extensions 85our %EXT_CORO = (); # coroutines bound to extensions
59our %EXT_MAP = (); # pluggable maps 86our %EXT_MAP = (); # pluggable maps
60 87
61our $RELOAD; # number of reloads so far 88our $RELOAD; # number of reloads so far, non-zero while in reload
62our @EVENT; 89our @EVENT;
63 90
64our $CONFDIR = confdir; 91our $CONFDIR = confdir;
65our $DATADIR = datadir; 92our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext"; 93our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod"; 94our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir; 95our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir; 96our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 97our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 98our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 99our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 100our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 101our $BDBDIR = "$LOCALDIR/db";
102our $PIDFILE = "$LOCALDIR/pid";
103our $RUNTIMEFILE = "$LOCALDIR/runtime";
104
105our %RESOURCE;
75 106
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 107our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 108our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 109our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 110our $USE_FSYNC = 1; # use fsync to write maps - default off
83 111
84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER; 112our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER; 113our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER; 114our $BDB_TRICKLE_WATCHER;
88our $DB_ENV; 115our $DB_ENV;
89 116
90our %CFG; 117our %CFG;
91 118
92our $UPTIME; $UPTIME ||= time; 119our $UPTIME; $UPTIME ||= time;
93our $RUNTIME; 120our $RUNTIME;
121our $NOW;
94 122
95our (%PLAYER, %PLAYER_LOADING); # all users 123our (%PLAYER, %PLAYER_LOADING); # all users
96our (%MAP, %MAP_LOADING ); # all maps 124our (%MAP, %MAP_LOADING ); # all maps
97our $LINK_MAP; # the special {link} map, which is always available 125our $LINK_MAP; # the special {link} map, which is always available
98 126
99# used to convert map paths into valid unix filenames by replacing / by ∕ 127# used to convert map paths into valid unix filenames by replacing / by ∕
100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 128our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
101 129
102our $LOAD; # a number between 0 (idle) and 1 (too many objects) 130our $LOAD; # a number between 0 (idle) and 1 (too many objects)
103our $LOADAVG; # same thing, but with alpha-smoothing 131our $LOADAVG; # same thing, but with alpha-smoothing
132our $JITTER; # average jitter
104our $tick_start; # for load detecting purposes 133our $TICK_START; # for load detecting purposes
134
135our @POST_INIT;
136
137our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow)
105 138
106binmode STDOUT; 139binmode STDOUT;
107binmode STDERR; 140binmode STDERR;
108 141
109# read virtual server time, if available 142# read virtual server time, if available
110unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 143unless ($RUNTIME || !-e $RUNTIMEFILE) {
111 open my $fh, "<", "$LOCALDIR/runtime" 144 open my $fh, "<", $RUNTIMEFILE
112 or die "unable to read runtime file: $!"; 145 or die "unable to read $RUNTIMEFILE file: $!";
113 $RUNTIME = <$fh> + 0.; 146 $RUNTIME = <$fh> + 0.;
114} 147}
115 148
116mkdir $_ 149mkdir $_
117 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 150 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
… …
162 195
163The raw value load value from the last tick. 196The raw value load value from the last tick.
164 197
165=item %cf::CFG 198=item %cf::CFG
166 199
167Configuration for the server, loaded from C</etc/crossfire/config>, or 200Configuration for the server, loaded from C</etc/deliantra-server/config>, or
168from wherever your confdir points to. 201from wherever your confdir points to.
169 202
170=item cf::wait_for_tick, cf::wait_for_tick_begin 203=item cf::wait_for_tick, cf::wait_for_tick_begin
171 204
172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 205These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 226 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
194 227
195 LOG llevError, $msg; 228 LOG llevError, $msg;
196 }; 229 };
197} 230}
231
232$Coro::State::DIEHOOK = sub {
233 return unless $^S eq 0; # "eq", not "=="
234
235 if ($Coro::current == $Coro::main) {#d#
236 warn "DIEHOOK called in main context, Coro bug?\n";#d#
237 return;#d#
238 }#d#
239
240 # kill coroutine otherwise
241 warn Carp::longmess $_[0];
242 Coro::terminate
243};
244
245$SIG{__DIE__} = sub { }; #d#?
198 246
199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 247@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 248@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 249@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 250@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
209for my $pkg (qw( 257for my $pkg (qw(
210 cf::global cf::attachable 258 cf::global cf::attachable
211 cf::object cf::object::player 259 cf::object cf::object::player
212 cf::client cf::player 260 cf::client cf::player
213 cf::arch cf::living 261 cf::arch cf::living
262 cf::map cf::mapspace
214 cf::map cf::party cf::region 263 cf::party cf::region
215)) { 264)) {
216 no strict 'refs';
217 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 265 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
218} 266}
219 267
220$Event::DIED = sub { 268$EV::DIED = sub {
221 warn "error in event callback: @_"; 269 warn "error in event callback: @_";
222}; 270};
223 271
224############################################################################# 272#############################################################################
225 273
… …
248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 296 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
249 $d 297 $d
250 } || "[unable to dump $_[0]: '$@']"; 298 } || "[unable to dump $_[0]: '$@']";
251} 299}
252 300
253=item $ref = cf::from_json $json 301=item $ref = cf::decode_json $json
254 302
255Converts a JSON string into the corresponding perl data structure. 303Converts a JSON string into the corresponding perl data structure.
256 304
257=item $json = cf::to_json $ref 305=item $json = cf::encode_json $ref
258 306
259Converts a perl data structure into its JSON representation. 307Converts a perl data structure into its JSON representation.
260 308
261=cut 309=cut
262 310
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 311our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264 312
265sub to_json ($) { $json_coder->encode ($_[0]) } 313sub encode_json($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) } 314sub decode_json($) { $json_coder->decode ($_[0]) }
315
316=item cf::post_init { BLOCK }
317
318Execute the given codeblock, I<after> all extensions have been (re-)loaded,
319but I<before> the server starts ticking again.
320
321The cdoeblock will have a single boolean argument to indicate whether this
322is a reload or not.
323
324=cut
325
326sub post_init(&) {
327 push @POST_INIT, shift;
328}
267 329
268=item cf::lock_wait $string 330=item cf::lock_wait $string
269 331
270Wait until the given lock is available. See cf::lock_acquire. 332Wait until the given lock is available. See cf::lock_acquire.
271 333
272=item my $lock = cf::lock_acquire $string 334=item my $lock = cf::lock_acquire $string
273 335
274Wait until the given lock is available and then acquires it and returns 336Wait until the given lock is available and then acquires it and returns
275a Coro::guard object. If the guard object gets destroyed (goes out of scope, 337a L<Guard> object. If the guard object gets destroyed (goes out of scope,
276for example when the coroutine gets canceled), the lock is automatically 338for example when the coroutine gets canceled), the lock is automatically
277returned. 339returned.
278 340
279Locks are *not* recursive, locking from the same coro twice results in a 341Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro. 342deadlocked coro.
… …
286 348
287Return true if the lock is currently active, i.e. somebody has locked it. 349Return true if the lock is currently active, i.e. somebody has locked it.
288 350
289=cut 351=cut
290 352
291our %LOCK; 353our $LOCKS = new Coro::SemaphoreSet;
292our %LOCKER;#d#
293 354
294sub lock_wait($) { 355sub lock_wait($) {
295 my ($key) = @_; 356 $LOCKS->wait ($_[0]);
296
297 if ($LOCKER{$key} == $Coro::current) {#d#
298 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
299 return;#d#
300 }#d#
301
302 # wait for lock, if any
303 while ($LOCK{$key}) {
304 push @{ $LOCK{$key} }, $Coro::current;
305 Coro::schedule;
306 }
307} 357}
308 358
309sub lock_acquire($) { 359sub lock_acquire($) {
310 my ($key) = @_; 360 $LOCKS->guard ($_[0])
311
312 # wait, to be sure we are not locked
313 lock_wait $key;
314
315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
317
318 Coro::guard {
319 delete $LOCKER{$key};#d#
320 # wake up all waiters, to be on the safe side
321 $_->ready for @{ delete $LOCK{$key} };
322 }
323} 361}
324 362
325sub lock_active($) { 363sub lock_active($) {
326 my ($key) = @_; 364 $LOCKS->count ($_[0]) < 1
327
328 ! ! $LOCK{$key}
329} 365}
330 366
331sub freeze_mainloop { 367sub freeze_mainloop {
332 return unless $TICK_WATCHER->is_active; 368 tick_inhibit_inc;
333 369
334 my $guard = Coro::guard { 370 &Guard::guard (\&tick_inhibit_dec);
335 $TICK_WATCHER->start; 371}
336 }; 372
337 $TICK_WATCHER->stop; 373=item cf::periodic $interval, $cb
338 $guard 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
339} 386}
340 387
341=item cf::get_slot $time[, $priority[, $name]] 388=item cf::get_slot $time[, $priority[, $name]]
342 389
343Allocate $time seconds of blocking CPU time at priority C<$priority>: 390Allocate $time seconds of blocking CPU time at priority C<$priority>:
… …
383 } 430 }
384 } 431 }
385}; 432};
386 433
387sub get_slot($;$$) { 434sub get_slot($;$$) {
435 return if tick_inhibit || $Coro::current == $Coro::main;
436
388 my ($time, $pri, $name) = @_; 437 my ($time, $pri, $name) = @_;
389 438
390 $time = $TICK * .6 if $time > $TICK * .6; 439 $time = $TICK * .6 if $time > $TICK * .6;
391 my $sig = new Coro::Signal; 440 my $sig = new Coro::Signal;
392 441
… …
406 455
407BEGIN { *async = \&Coro::async_pool } 456BEGIN { *async = \&Coro::async_pool }
408 457
409=item cf::sync_job { BLOCK } 458=item cf::sync_job { BLOCK }
410 459
411The design of Crossfire TRT requires that the main coroutine ($Coro::main) 460The design of Deliantra requires that the main coroutine ($Coro::main)
412is always able to handle events or runnable, as Crossfire TRT is only 461is always able to handle events or runnable, as Deliantra is only
413partly 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
414acceptable. 463acceptable.
415 464
416If 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
417the given BLOCK in another coroutine while waiting for the result. The 466the given BLOCK in another coroutine while waiting for the result. The
… …
422 471
423sub sync_job(&) { 472sub sync_job(&) {
424 my ($job) = @_; 473 my ($job) = @_;
425 474
426 if ($Coro::current == $Coro::main) { 475 if ($Coro::current == $Coro::main) {
427 my $time = Event::time; 476 my $time = EV::time;
428 477
429 # this is the main coro, too bad, we have to block 478 # this is the main coro, too bad, we have to block
430 # till the operation succeeds, freezing the server :/ 479 # till the operation succeeds, freezing the server :/
431 480
432 LOG llevError, Carp::longmess "sync job";#d# 481 LOG llevError, Carp::longmess "sync job";#d#
433 482
434 # TODO: use suspend/resume instead
435 # (but this is cancel-safe)
436 my $freeze_guard = freeze_mainloop; 483 my $freeze_guard = freeze_mainloop;
437 484
438 my $busy = 1; 485 my $busy = 1;
439 my @res; 486 my @res;
440 487
… …
447 494
448 while ($busy) { 495 while ($busy) {
449 if (Coro::nready) { 496 if (Coro::nready) {
450 Coro::cede_notself; 497 Coro::cede_notself;
451 } else { 498 } else {
452 Event::one_event; 499 EV::loop EV::LOOP_ONESHOT;
453 } 500 }
454 } 501 }
455 502
456 $time = Event::time - $time; 503 my $time = EV::time - $time;
457 504
458 LOG llevError | logBacktrace, Carp::longmess "long sync job"
459 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
460
461 $tick_start += $time; # do not account sync jobs to server load 505 $TICK_START += $time; # do not account sync jobs to server load
462 506
463 wantarray ? @res : $res[0] 507 wantarray ? @res : $res[0]
464 } else { 508 } else {
465 # we are in another coroutine, how wonderful, everything just works 509 # we are in another coroutine, how wonderful, everything just works
466 510
… …
491=item fork_call { }, $args 535=item fork_call { }, $args
492 536
493Executes the given code block with the given arguments in a seperate 537Executes the given code block with the given arguments in a seperate
494process, returning the results. Everything must be serialisable with 538process, returning the results. Everything must be serialisable with
495Coro::Storable. May, of course, block. Note that the executed sub may 539Coro::Storable. May, of course, block. Note that the executed sub may
496never block itself or use any form of Event handling. 540never block itself or use any form of event handling.
497 541
498=cut 542=cut
499 543
500sub fork_call(&@) { 544sub fork_call(&@) {
501 my ($cb, @args) = @_; 545 my ($cb, @args) = @_;
… …
508 reset_signals; 552 reset_signals;
509 &$cb 553 &$cb
510 }, @args; 554 }, @args;
511 555
512 wantarray ? @res : $res[-1] 556 wantarray ? @res : $res[-1]
557}
558
559=item $coin = coin_from_name $name
560
561=cut
562
563our %coin_alias = (
564 "silver" => "silvercoin",
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
513} 584}
514 585
515=item $value = cf::db_get $family => $key 586=item $value = cf::db_get $family => $key
516 587
517Returns a single value from the environment database. 588Returns a single value from the environment database.
… …
656 727
657############################################################################# 728#############################################################################
658 729
659=head2 ATTACHABLE OBJECTS 730=head2 ATTACHABLE OBJECTS
660 731
661Many objects in crossfire are so-called attachable objects. That means you can 732Many objects in deliantra are so-called attachable objects. That means you can
662attach callbacks/event handlers (a collection of which is called an "attachment") 733attach callbacks/event handlers (a collection of which is called an "attachment")
663to it. All such attachable objects support the following methods. 734to it. All such attachable objects support the following methods.
664 735
665In 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>
666C<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
667Crossfire TRT). 738Deliantra).
668 739
669=over 4 740=over 4
670 741
671=item $attachable->attach ($attachment, key => $value...) 742=item $attachable->attach ($attachment, key => $value...)
672 743
… …
716=item cf::CLASS::attachment $name, ... 787=item cf::CLASS::attachment $name, ...
717 788
718Register an attachment by C<$name> through which attachable objects of the 789Register an attachment by C<$name> through which attachable objects of the
719given CLASS can refer to this attachment. 790given CLASS can refer to this attachment.
720 791
721Some classes such as crossfire maps and objects can specify attachments 792Some classes such as deliantra maps and objects can specify attachments
722that are attached at load/instantiate time, thus the need for a name. 793that are attached at load/instantiate time, thus the need for a name.
723 794
724These calls expect any number of the following handler/hook descriptions: 795These calls expect any number of the following handler/hook descriptions:
725 796
726=over 4 797=over 4
… …
954 } 1025 }
955 1026
956 0 1027 0
957} 1028}
958 1029
959=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1030=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
960 1031
961=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1032=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
962 1033
963Generate an object-specific event with the given arguments. 1034Generate an object-specific event with the given arguments.
964 1035
… …
1017 1088
1018sub reattach { 1089sub reattach {
1019 # basically do the same as instantiate, without calling instantiate 1090 # basically do the same as instantiate, without calling instantiate
1020 my ($obj) = @_; 1091 my ($obj) = @_;
1021 1092
1093 # no longer needed after getting rid of delete_package?
1022 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
1023 1095
1024 my $registry = $obj->registry; 1096 my $registry = $obj->registry;
1025 1097
1026 @$registry = (); 1098 @$registry = ();
1027 1099
… …
1042cf::attachable->attach ( 1114cf::attachable->attach (
1043 prio => -1000000, 1115 prio => -1000000,
1044 on_instantiate => sub { 1116 on_instantiate => sub {
1045 my ($obj, $data) = @_; 1117 my ($obj, $data) = @_;
1046 1118
1047 $data = from_json $data; 1119 $data = decode_json $data;
1048 1120
1049 for (@$data) { 1121 for (@$data) {
1050 my ($name, $args) = @$_; 1122 my ($name, $args) = @$_;
1051 1123
1052 $obj->attach ($name, %{$args || {} }); 1124 $obj->attach ($name, %{$args || {} });
… …
1073 utf8::decode (my $decname = $filename); 1145 utf8::decode (my $decname = $filename);
1074 warn sprintf "saving %s (%d,%d)\n", 1146 warn sprintf "saving %s (%d,%d)\n",
1075 $decname, length $$rdata, scalar @$objs; 1147 $decname, length $$rdata, scalar @$objs;
1076 1148
1077 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1149 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1078 chmod SAVE_MODE, $fh; 1150 aio_chmod $fh, SAVE_MODE;
1079 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1151 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1080 aio_fsync $fh if $cf::USE_FSYNC; 1152 aio_fsync $fh if $cf::USE_FSYNC;
1081 close $fh; 1153 aio_close $fh;
1082 1154
1083 if (@$objs) { 1155 if (@$objs) {
1084 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) {
1085 chmod SAVE_MODE, $fh; 1157 aio_chmod $fh, SAVE_MODE;
1086 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1158 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1087 aio_write $fh, 0, (length $data), $data, 0; 1159 aio_write $fh, 0, (length $data), $data, 0;
1088 aio_fsync $fh if $cf::USE_FSYNC; 1160 aio_fsync $fh if $cf::USE_FSYNC;
1089 close $fh; 1161 aio_close $fh;
1090 aio_rename "$filename.pst~", "$filename.pst"; 1162 aio_rename "$filename.pst~", "$filename.pst";
1091 } 1163 }
1092 } else { 1164 } else {
1093 aio_unlink "$filename.pst"; 1165 aio_unlink "$filename.pst";
1094 } 1166 }
1095 1167
1096 aio_rename "$filename~", $filename; 1168 aio_rename "$filename~", $filename;
1169
1170 $filename =~ s%/[^/]+$%%;
1171 aio_pathsync $filename if $cf::USE_FSYNC;
1097 } else { 1172 } else {
1098 warn "FATAL: $filename~: $!\n"; 1173 warn "FATAL: $filename~: $!\n";
1099 } 1174 }
1100 } else { 1175 } else {
1101 aio_unlink $filename; 1176 aio_unlink $filename;
… …
1194 my ($name, $cb) = @_; 1269 my ($name, $cb) = @_;
1195 1270
1196 $EXTICMD{$name} = $cb; 1271 $EXTICMD{$name} = $cb;
1197} 1272}
1198 1273
1274use File::Glob ();
1275
1199cf::player->attach ( 1276cf::player->attach (
1200 on_command => sub { 1277 on_command => sub {
1201 my ($pl, $name, $params) = @_; 1278 my ($pl, $name, $params) = @_;
1202 1279
1203 my $cb = $COMMAND{$name} 1280 my $cb = $COMMAND{$name}
… …
1235 1312
1236 cf::override; 1313 cf::override;
1237 }, 1314 },
1238); 1315);
1239 1316
1317# "readahead" all extensions
1318sub cache_extensions {
1319 my $grp = IO::AIO::aio_group;
1320
1321 add $grp IO::AIO::aio_readdir $LIBDIR, sub {
1322 for (grep /\.ext$/, @{$_[0]}) {
1323 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1324 }
1325 };
1326
1327 $grp
1328}
1329
1240sub load_extensions { 1330sub load_extensions {
1241 cf::sync_job { 1331 cf::sync_job {
1242 my %todo; 1332 my %todo;
1243 1333
1244 for my $path (<$LIBDIR/*.ext>) { 1334 for my $path (<$LIBDIR/*.ext>) {
… …
1263 1353
1264 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1354 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1265 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1355 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1266 1356
1267 $ext{source} = 1357 $ext{source} =
1268 "package $pkg; use strict; use utf8;\n" 1358 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1269 . "#line 1 \"$path\"\n{\n" 1359 . "#line 1 \"$path\"\n{\n"
1270 . $source 1360 . $source
1271 . "\n};\n1"; 1361 . "\n};\n1";
1272 1362
1273 $todo{$base} = \%ext; 1363 $todo{$base} = \%ext;
… …
1289 my $msg = $@ ? "$v->{path}: $@\n" 1379 my $msg = $@ ? "$v->{path}: $@\n"
1290 : "$v->{base}: extension inactive.\n"; 1380 : "$v->{base}: extension inactive.\n";
1291 1381
1292 if (exists $v->{meta}{mandatory}) { 1382 if (exists $v->{meta}{mandatory}) {
1293 warn $msg; 1383 warn $msg;
1294 warn "mandatory extension failed to load, exiting.\n"; 1384 cf::cleanup "mandatory extension failed to load, exiting.";
1295 exit 1;
1296 } 1385 }
1297 1386
1298 warn $msg; 1387 warn $msg;
1299 } 1388 }
1300 1389
… …
1314 1403
1315=back 1404=back
1316 1405
1317=head2 CORE EXTENSIONS 1406=head2 CORE EXTENSIONS
1318 1407
1319Functions and methods that extend core crossfire objects. 1408Functions and methods that extend core deliantra objects.
1320 1409
1321=cut 1410=cut
1322 1411
1323package cf::player; 1412package cf::player;
1324 1413
… …
1367 1456
1368sub exists($) { 1457sub exists($) {
1369 my ($login) = @_; 1458 my ($login) = @_;
1370 1459
1371 $cf::PLAYER{$login} 1460 $cf::PLAYER{$login}
1372 or cf::sync_job { !aio_stat path $login } 1461 or !aio_stat path $login
1373} 1462}
1374 1463
1375sub find($) { 1464sub find($) {
1376 return $cf::PLAYER{$_[0]} || do { 1465 return $cf::PLAYER{$_[0]} || do {
1377 my $login = $_[0]; 1466 my $login = $_[0];
… …
1389 my $f = new_from_file cf::object::thawer path $login 1478 my $f = new_from_file cf::object::thawer path $login
1390 or return; 1479 or return;
1391 1480
1392 my $pl = cf::player::load_pl $f 1481 my $pl = cf::player::load_pl $f
1393 or return; 1482 or return;
1483
1394 local $cf::PLAYER_LOADING{$login} = $pl; 1484 local $cf::PLAYER_LOADING{$login} = $pl;
1395 $f->resolve_delayed_derefs; 1485 $f->resolve_delayed_derefs;
1396 $cf::PLAYER{$login} = $pl 1486 $cf::PLAYER{$login} = $pl
1397 } 1487 }
1398 } 1488 }
… …
1408 1498
1409 return if $pl->{deny_save}; 1499 return if $pl->{deny_save};
1410 1500
1411 aio_mkdir playerdir $pl, 0770; 1501 aio_mkdir playerdir $pl, 0770;
1412 $pl->{last_save} = $cf::RUNTIME; 1502 $pl->{last_save} = $cf::RUNTIME;
1503
1504 cf::get_slot 0.01;
1413 1505
1414 $pl->save_pl ($path); 1506 $pl->save_pl ($path);
1415 cf::cede_to_tick; 1507 cf::cede_to_tick;
1416} 1508}
1417 1509
… …
1449 my ($pl) = @_; 1541 my ($pl) = @_;
1450 1542
1451 my $name = $pl->ob->name; 1543 my $name = $pl->ob->name;
1452 1544
1453 $pl->{deny_save} = 1; 1545 $pl->{deny_save} = 1;
1454 $pl->password ("*"); # this should lock out the player until we nuked the dir 1546 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1455 1547
1456 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1548 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1457 $pl->deactivate; 1549 $pl->deactivate;
1550 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1551 $pl->ob->check_score;
1458 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1552 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1459 $pl->ns->destroy if $pl->ns; 1553 $pl->ns->destroy if $pl->ns;
1460 1554
1461 my $path = playerdir $pl; 1555 my $path = playerdir $pl;
1462 my $temp = "$path~$cf::RUNTIME~deleting~"; 1556 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1501 1595
1502 for my $login (@$dirs) { 1596 for my $login (@$dirs) {
1503 my $path = path $login; 1597 my $path = path $login;
1504 1598
1505 # a .pst is a dead give-away for a valid player 1599 # a .pst is a dead give-away for a valid player
1506 unless (-e "$path.pst") { 1600 # if no pst file found, open and chekc for blocked users
1601 if (aio_stat "$path.pst") {
1507 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1602 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1508 aio_read $fh, 0, 512, my $buf, 0 or next; 1603 aio_read $fh, 0, 512, my $buf, 0 or next;
1509 $buf !~ /^password -------------$/m or next; # official not-valid tag 1604 $buf !~ /^password -------------$/m or next; # official not-valid tag
1510 } 1605 }
1511 1606
… …
1542 } 1637 }
1543 1638
1544 \@paths 1639 \@paths
1545} 1640}
1546 1641
1547=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1642=item $protocol_xml = $player->expand_cfpod ($cfpod)
1548 1643
1549Expand crossfire pod fragments into protocol xml. 1644Expand deliantra pod fragments into protocol xml.
1550
1551=cut
1552
1553sub expand_cfpod {
1554 ((my $self), (local $_)) = @_;
1555
1556 # escape & and <
1557 s/&/&amp;/g;
1558 s/(?<![BIUGHT])</&lt;/g;
1559
1560 # this is buggy, it needs to properly take care of nested <'s
1561
1562 1 while
1563 # replace B<>, I<>, U<> etc.
1564 s/B<([^\>]*)>/<b>$1<\/b>/
1565 || s/I<([^\>]*)>/<i>$1<\/i>/
1566 || s/U<([^\>]*)>/<u>$1<\/u>/
1567 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1568 # replace G<male|female> tags
1569 || s{G<([^>|]*)\|([^>]*)>}{
1570 $self->gender ? $2 : $1
1571 }ge
1572 # replace H<hint text>
1573 || s{H<([^\>]*)>}
1574 {
1575 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1576 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1577 "")
1578 [$self->{hintmode}]
1579 }ge;
1580
1581 # create single paragraphs (very hackish)
1582 s/(?<=\S)\n(?=\w)/ /g;
1583
1584 # compress some whitespace
1585 s/\s+\n/\n/g; # ws line-ends
1586 s/\n\n+/\n/g; # double lines
1587 s/^\n+//; # beginning lines
1588 s/\n+$//; # ending lines
1589
1590 $_
1591}
1592
1593sub hintmode {
1594 $_[0]{hintmode} = $_[1] if @_ > 1;
1595 $_[0]{hintmode}
1596}
1597 1645
1598=item $player->ext_reply ($msgid, @msg) 1646=item $player->ext_reply ($msgid, @msg)
1599 1647
1600Sends an ext reply to the player. 1648Sends an ext reply to the player.
1601 1649
… …
1668our $MAX_RESET = 3600; 1716our $MAX_RESET = 3600;
1669our $DEFAULT_RESET = 3000; 1717our $DEFAULT_RESET = 3000;
1670 1718
1671sub generate_random_map { 1719sub generate_random_map {
1672 my ($self, $rmp) = @_; 1720 my ($self, $rmp) = @_;
1721
1722 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1723
1673 # mit "rum" bekleckern, nicht 1724 # mit "rum" bekleckern, nicht
1674 $self->_create_random_map ( 1725 $self->_create_random_map (
1675 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1726 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1676 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1727 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1677 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1728 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1799 1850
1800# the temporary/swap location 1851# the temporary/swap location
1801sub save_path { 1852sub save_path {
1802 my ($self) = @_; 1853 my ($self) = @_;
1803 1854
1804 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1855 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1805 "$TMPDIR/$path.map" 1856 "$TMPDIR/$path.map"
1806} 1857}
1807 1858
1808# the unique path, undef == no special unique path 1859# the unique path, undef == no special unique path
1809sub uniq_path { 1860sub uniq_path {
1810 my ($self) = @_; 1861 my ($self) = @_;
1811 1862
1812 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1863 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1813 "$UNIQUEDIR/$path" 1864 "$UNIQUEDIR/$path"
1814} 1865}
1815 1866
1816# and all this just because we cannot iterate over 1867# and all this just because we cannot iterate over
1817# all maps in C++... 1868# all maps in C++...
… …
1911sub find { 1962sub find {
1912 my ($path, $origin) = @_; 1963 my ($path, $origin) = @_;
1913 1964
1914 $path = normalise $path, $origin && $origin->path; 1965 $path = normalise $path, $origin && $origin->path;
1915 1966
1916 cf::lock_wait "map_data:$path";#d#remove 1967 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1917 cf::lock_wait "map_find:$path"; 1968 my $guard2 = cf::lock_acquire "map_find:$path";
1918 1969
1919 $cf::MAP{$path} || do { 1970 $cf::MAP{$path} || do {
1920 my $guard1 = cf::lock_acquire "map_find:$path";
1921 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1922
1923 my $map = new_from_path cf::map $path 1971 my $map = new_from_path cf::map $path
1924 or return; 1972 or return;
1925 1973
1926 $map->{last_save} = $cf::RUNTIME; 1974 $map->{last_save} = $cf::RUNTIME;
1927 1975
… …
1929 or return; 1977 or return;
1930 1978
1931 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1979 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1932 # doing this can freeze the server in a sync job, obviously 1980 # doing this can freeze the server in a sync job, obviously
1933 #$cf::WAIT_FOR_TICK->wait; 1981 #$cf::WAIT_FOR_TICK->wait;
1982 undef $guard2;
1934 undef $guard1; 1983 undef $guard1;
1935 undef $guard2;
1936 $map->reset; 1984 $map->reset;
1937 return find $path; 1985 return find $path;
1938 } 1986 }
1939 1987
1940 $cf::MAP{$path} = $map 1988 $cf::MAP{$path} = $map
… …
1967 my $f = new_from_file cf::object::thawer $self->{load_path}; 2015 my $f = new_from_file cf::object::thawer $self->{load_path};
1968 $f->skip_block; 2016 $f->skip_block;
1969 $self->_load_objects ($f) 2017 $self->_load_objects ($f)
1970 or return; 2018 or return;
1971 2019
1972 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2020 $self->post_load_original
1973 if delete $self->{load_original}; 2021 if delete $self->{load_original};
1974 2022
1975 if (my $uniq = $self->uniq_path) { 2023 if (my $uniq = $self->uniq_path) {
1976 utf8::encode $uniq; 2024 utf8::encode $uniq;
1977 unless (aio_stat $uniq) { 2025 unless (aio_stat $uniq) {
… …
2003 } 2051 }
2004 2052
2005 $self->{last_save} = $cf::RUNTIME; 2053 $self->{last_save} = $cf::RUNTIME;
2006 $self->last_access ($cf::RUNTIME); 2054 $self->last_access ($cf::RUNTIME);
2007 2055
2008 $self->in_memory (cf::MAP_IN_MEMORY); 2056 $self->in_memory (cf::MAP_ACTIVE);
2009 } 2057 }
2010 2058
2011 $self->post_load; 2059 $self->post_load;
2012} 2060}
2013 2061
… …
2071 my ($path, $origin, $load) = @_; 2119 my ($path, $origin, $load) = @_;
2072 2120
2073 $path = normalise $path, $origin && $origin->{path}; 2121 $path = normalise $path, $origin && $origin->{path};
2074 2122
2075 if (my $map = $cf::MAP{$path}) { 2123 if (my $map = $cf::MAP{$path}) {
2076 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2124 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2077 } 2125 }
2078 2126
2079 $MAP_PREFETCH{$path} |= $load; 2127 $MAP_PREFETCH{$path} |= $load;
2080 2128
2081 $MAP_PREFETCHER ||= cf::async { 2129 $MAP_PREFETCHER ||= cf::async {
… …
2118 cf::async { 2166 cf::async {
2119 $Coro::current->{desc} = "map player save"; 2167 $Coro::current->{desc} = "map player save";
2120 $_->contr->save for $self->players; 2168 $_->contr->save for $self->players;
2121 }; 2169 };
2122 2170
2171 cf::get_slot 0.02;
2172
2123 if ($uniq) { 2173 if ($uniq) {
2124 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2174 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2125 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2175 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2126 } else { 2176 } else {
2127 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2177 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
… …
2135 $self->save; 2185 $self->save;
2136 2186
2137 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2187 my $lock = cf::lock_acquire "map_data:$self->{path}";
2138 2188
2139 return if $self->players; 2189 return if $self->players;
2140 return if $self->in_memory != cf::MAP_IN_MEMORY; 2190 return if $self->in_memory != cf::MAP_ACTIVE;
2141 return if $self->{deny_save}; 2191 return if $self->{deny_save};
2142 2192
2143 $self->in_memory (cf::MAP_SWAPPED); 2193 $self->in_memory (cf::MAP_SWAPPED);
2144 2194
2145 $self->deactivate; 2195 $self->deactivate;
… …
2263 2313
2264sub unique_maps() { 2314sub unique_maps() {
2265 [ 2315 [
2266 map { 2316 map {
2267 utf8::decode $_; 2317 utf8::decode $_;
2268 /\.map$/ 2318 s/\.map$//; # TODO future compatibility hack
2319 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2320 ? ()
2269 ? normalise $_ 2321 : normalise $_
2270 : ()
2271 } @{ aio_readdir $UNIQUEDIR or [] } 2322 } @{ aio_readdir $UNIQUEDIR or [] }
2272 ] 2323 ]
2273} 2324}
2274 2325
2275package cf;
2276
2277=back 2326=back
2278 2327
2279=head3 cf::object 2328=head3 cf::object
2280 2329
2281=cut 2330=cut
… …
2284 2333
2285=over 4 2334=over 4
2286 2335
2287=item $ob->inv_recursive 2336=item $ob->inv_recursive
2288 2337
2289Returns the inventory of the object _and_ their inventories, recursively. 2338Returns the inventory of the object I<and> their inventories, recursively,
2339but I<not> the object itself.
2290 2340
2291=cut 2341=cut
2292 2342
2293sub inv_recursive_; 2343sub inv_recursive_;
2294sub inv_recursive_ { 2344sub inv_recursive_ {
… …
2299 inv_recursive_ inv $_[0] 2349 inv_recursive_ inv $_[0]
2300} 2350}
2301 2351
2302=item $ref = $ob->ref 2352=item $ref = $ob->ref
2303 2353
2304creates and returns a persistent reference to an objetc that can be stored as a string. 2354Creates and returns a persistent reference to an object that can be stored as a string.
2305 2355
2306=item $ob = cf::object::deref ($refstring) 2356=item $ob = cf::object::deref ($refstring)
2307 2357
2308returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2358returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2309even if the object actually exists. May block. 2359even if the object actually exists. May block.
… …
2341can be C<undef>. Does the right thing when the player is currently in a 2391can be C<undef>. Does the right thing when the player is currently in a
2342dialogue with the given NPC character. 2392dialogue with the given NPC character.
2343 2393
2344=cut 2394=cut
2345 2395
2396our $SAY_CHANNEL = {
2397 id => "say",
2398 title => "Map",
2399 reply => "say ",
2400 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2401};
2402
2403our $CHAT_CHANNEL = {
2404 id => "chat",
2405 title => "Chat",
2406 reply => "chat ",
2407 tooltip => "Player chat and shouts, global to the server.",
2408};
2409
2346# rough implementation of a future "reply" method that works 2410# rough implementation of a future "reply" method that works
2347# with dialog boxes. 2411# with dialog boxes.
2348#TODO: the first argument must go, split into a $npc->reply_to ( method 2412#TODO: the first argument must go, split into a $npc->reply_to ( method
2349sub cf::object::player::reply($$$;$) { 2413sub cf::object::player::reply($$$;$) {
2350 my ($self, $npc, $msg, $flags) = @_; 2414 my ($self, $npc, $msg, $flags) = @_;
… …
2361 my $dialog = $pl->{npc_dialog}; 2425 my $dialog = $pl->{npc_dialog};
2362 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2426 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2363 2427
2364 } else { 2428 } else {
2365 $msg = $npc->name . " says: $msg" if $npc; 2429 $msg = $npc->name . " says: $msg" if $npc;
2366 $self->message ($msg, $flags); 2430 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2367 } 2431 }
2368 } 2432 }
2369} 2433}
2370 2434
2371=item $object->send_msg ($channel, $msg, $color, [extra...]) 2435=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2396 2460
2397=item $player_object->enter_link 2461=item $player_object->enter_link
2398 2462
2399Freezes the player and moves him/her to a special map (C<{link}>). 2463Freezes the player and moves him/her to a special map (C<{link}>).
2400 2464
2401The player should be reasonably safe there for short amounts of time. You 2465The player should be reasonably safe there for short amounts of time (e.g.
2402I<MUST> call C<leave_link> as soon as possible, though. 2466for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2467though, as the palyer cannot control the character while it is on the link
2468map.
2403 2469
2404Will never block. 2470Will never block.
2405 2471
2406=item $player_object->leave_link ($map, $x, $y) 2472=item $player_object->leave_link ($map, $x, $y)
2407 2473
… …
2465 2531
2466 $map->load; 2532 $map->load;
2467 $map->load_neighbours; 2533 $map->load_neighbours;
2468 2534
2469 return unless $self->contr->active; 2535 return unless $self->contr->active;
2536 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2470 $self->activate_recursive; 2537 $self->activate_recursive;
2471 2538
2472 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2539 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2473 $self->enter_map ($map, $x, $y); 2540 $self->enter_map ($map, $x, $y);
2474} 2541}
… …
2478Moves the player to the given map-path and coordinates by first freezing 2545Moves the player to the given map-path and coordinates by first freezing
2479her, loading and preparing them map, calling the provided $check callback 2546her, loading and preparing them map, calling the provided $check callback
2480that has to return the map if sucecssful, and then unfreezes the player on 2547that has to return the map if sucecssful, and then unfreezes the player on
2481the new (success) or old (failed) map position. In either case, $done will 2548the new (success) or old (failed) map position. In either case, $done will
2482be called at the end of this process. 2549be called at the end of this process.
2550
2551Note that $check will be called with a potentially non-loaded map, so if
2552it needs a loaded map it has to call C<< ->load >>.
2483 2553
2484=cut 2554=cut
2485 2555
2486our $GOTOGEN; 2556our $GOTOGEN;
2487 2557
… …
2566} 2636}
2567 2637
2568sub prepare_random_map { 2638sub prepare_random_map {
2569 my ($exit) = @_; 2639 my ($exit) = @_;
2570 2640
2571 my $guard = cf::lock_acquire "exit_prepare:$exit";
2572
2573 # all this does is basically replace the /! path by 2641 # all this does is basically replace the /! path by
2574 # a new random map path (?random/...) with a seed 2642 # a new random map path (?random/...) with a seed
2575 # that depends on the exit object 2643 # that depends on the exit object
2576 2644
2577 my $rmp = parse_random_map_params $exit->msg; 2645 my $rmp = parse_random_map_params $exit->msg;
… …
2579 if ($exit->map) { 2647 if ($exit->map) {
2580 $rmp->{region} = $exit->region->name; 2648 $rmp->{region} = $exit->region->name;
2581 $rmp->{origin_map} = $exit->map->path; 2649 $rmp->{origin_map} = $exit->map->path;
2582 $rmp->{origin_x} = $exit->x; 2650 $rmp->{origin_x} = $exit->x;
2583 $rmp->{origin_y} = $exit->y; 2651 $rmp->{origin_y} = $exit->y;
2652
2653 $exit->map->touch;
2584 } 2654 }
2585 2655
2586 $rmp->{random_seed} ||= $exit->random_seed; 2656 $rmp->{random_seed} ||= $exit->random_seed;
2587 2657
2588 my $data = cf::to_json $rmp; 2658 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2589 my $md5 = Digest::MD5::md5_hex $data; 2659 my $md5 = Digest::MD5::md5_hex $data;
2590 my $meta = "$RANDOMDIR/$md5.meta"; 2660 my $meta = "$RANDOMDIR/$md5.meta";
2591 2661
2592 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2662 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2593 aio_write $fh, 0, (length $data), $data, 0; 2663 aio_write $fh, 0, (length $data), $data, 0;
2594 undef $fh; 2664 undef $fh;
2595 aio_rename "$meta~", $meta; 2665 aio_rename "$meta~", $meta;
2596 2666
2667 my $slaying = "?random/$md5";
2668
2669 if ($exit->valid) {
2597 $exit->slaying ("?random/$md5"); 2670 $exit->slaying ("?random/$md5");
2598 $exit->msg (undef); 2671 $exit->msg (undef);
2672 }
2599 } 2673 }
2600} 2674}
2601 2675
2602sub cf::object::player::enter_exit { 2676sub cf::object::player::enter_exit {
2603 my ($self, $exit) = @_; 2677 my ($self, $exit) = @_;
2604 2678
2605 return unless $self->type == cf::PLAYER; 2679 return unless $self->type == cf::PLAYER;
2606 2680
2607 if ($exit->slaying eq "/!") {
2608 #TODO: this should de-fi-ni-te-ly not be a sync-job
2609 # the problem is that $exit might not survive long enough
2610 # so it needs to be done right now, right here
2611 cf::sync_job { prepare_random_map $exit };
2612 }
2613
2614 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2615 my $hp = $exit->stats->hp;
2616 my $sp = $exit->stats->sp;
2617
2618 $self->enter_link; 2681 $self->enter_link;
2619 2682
2620 # if exit is damned, update players death & WoR home-position
2621 $self->contr->savebed ($slaying, $hp, $sp)
2622 if $exit->flag (FLAG_DAMNED);
2623
2624 (async { 2683 (async {
2625 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2684 $Coro::current->{desc} = "enter_exit";
2626 2685
2627 $self->deactivate_recursive; # just to be sure
2628 unless (eval { 2686 unless (eval {
2687 $self->deactivate_recursive; # just to be sure
2688
2689 # random map handling
2690 {
2691 my $guard = cf::lock_acquire "exit_prepare:$exit";
2692
2693 prepare_random_map $exit
2694 if $exit->slaying eq "/!";
2695 }
2696
2697 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2698 my $x = $exit->stats->hp;
2699 my $y = $exit->stats->sp;
2700
2629 $self->goto ($slaying, $hp, $sp); 2701 $self->goto ($map, $x, $y);
2630 2702
2703 # if exit is damned, update players death & WoR home-position
2704 $self->contr->savebed ($map, $x, $y)
2705 if $exit->flag (cf::FLAG_DAMNED);
2706
2631 1; 2707 1
2632 }) { 2708 }) {
2633 $self->message ("Something went wrong deep within the crossfire server. " 2709 $self->message ("Something went wrong deep within the deliantra server. "
2634 . "I'll try to bring you back to the map you were before. " 2710 . "I'll try to bring you back to the map you were before. "
2635 . "Please report this to the dungeon master!", 2711 . "Please report this to the dungeon master!",
2636 cf::NDI_UNIQUE | cf::NDI_RED); 2712 cf::NDI_UNIQUE | cf::NDI_RED);
2637 2713
2638 warn "ERROR in enter_exit: $@"; 2714 warn "ERROR in enter_exit: $@";
… …
2666the message, with C<log> being the default. If C<$color> is negative, suppress 2742the message, with C<log> being the default. If C<$color> is negative, suppress
2667the message unless the client supports the msg packet. 2743the message unless the client supports the msg packet.
2668 2744
2669=cut 2745=cut
2670 2746
2747# non-persistent channels (usually the info channel)
2671our %CHANNEL = ( 2748our %CHANNEL = (
2672 "c/identify" => { 2749 "c/identify" => {
2673 id => "infobox", 2750 id => "infobox",
2674 title => "Identify", 2751 title => "Identify",
2675 reply => undef, 2752 reply => undef,
… …
2691 id => "infobox", 2768 id => "infobox",
2692 title => "Look", 2769 title => "Look",
2693 reply => undef, 2770 reply => undef,
2694 tooltip => "What you saw there", 2771 tooltip => "What you saw there",
2695 }, 2772 },
2773 "c/who" => {
2774 id => "infobox",
2775 title => "Players",
2776 reply => undef,
2777 tooltip => "Shows players who are currently online",
2778 },
2779 "c/body" => {
2780 id => "infobox",
2781 title => "Body Parts",
2782 reply => undef,
2783 tooltip => "Shows which body parts you posess and are available",
2784 },
2785 "c/skills" => {
2786 id => "infobox",
2787 title => "Skills",
2788 reply => undef,
2789 tooltip => "Shows your experience per skill and item power",
2790 },
2791 "c/uptime" => {
2792 id => "infobox",
2793 title => "Uptime",
2794 reply => undef,
2795 tooltip => "How long the server has been running since last restart",
2796 },
2797 "c/mapinfo" => {
2798 id => "infobox",
2799 title => "Map Info",
2800 reply => undef,
2801 tooltip => "Information related to the maps",
2802 },
2803 "c/party" => {
2804 id => "party",
2805 title => "Party",
2806 reply => "gsay ",
2807 tooltip => "Messages and chat related to your party",
2808 },
2696); 2809);
2697 2810
2698sub cf::client::send_msg { 2811sub cf::client::send_msg {
2699 my ($self, $channel, $msg, $color, @extra) = @_; 2812 my ($self, $channel, $msg, $color, @extra) = @_;
2700 2813
2701 $msg = $self->pl->expand_cfpod ($msg); 2814 $msg = $self->pl->expand_cfpod ($msg)
2815 unless $color & cf::NDI_VERBATIM;
2702 2816
2703 $color &= cf::NDI_CLIENT_MASK; # just in case... 2817 $color &= cf::NDI_CLIENT_MASK; # just in case...
2704 2818
2705 # check predefined channels, for the benefit of C 2819 # check predefined channels, for the benefit of C
2706 if ($CHANNEL{$channel}) { 2820 if ($CHANNEL{$channel}) {
… …
2727 if ($self->can_msg) { 2841 if ($self->can_msg) {
2728 # default colour, mask it out 2842 # default colour, mask it out
2729 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 2843 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2730 if $color & cf::NDI_DEF; 2844 if $color & cf::NDI_DEF;
2731 2845
2732 $self->send_packet ("msg " . $self->{json_coder}->encode ( 2846 my $pkt = "msg "
2847 . $self->{json_coder}->encode (
2733 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 2848 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2849 );
2850
2851 # try lzf for large packets
2852 $pkt = "lzf " . Compress::LZF::compress $pkt
2853 if 1024 <= length $pkt and $self->{can_lzf};
2854
2855 # split very large packets
2856 if (8192 < length $pkt and $self->{can_lzf}) {
2857 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2858 $pkt = "frag";
2859 }
2860
2861 $self->send_packet ($pkt);
2734 } else { 2862 } else {
2735 if ($color >= 0) { 2863 if ($color >= 0) {
2736 # replace some tags by gcfclient-compatible ones 2864 # replace some tags by gcfclient-compatible ones
2737 for ($msg) { 2865 for ($msg) {
2738 1 while 2866 1 while
… …
2937 3065
2938The following functions and methods are available within a safe environment: 3066The following functions and methods are available within a safe environment:
2939 3067
2940 cf::object 3068 cf::object
2941 contr pay_amount pay_player map x y force_find force_add destroy 3069 contr pay_amount pay_player map x y force_find force_add destroy
2942 insert remove name archname title slaying race decrease_ob_nr 3070 insert remove name archname title slaying race decrease split
2943 3071
2944 cf::object::player 3072 cf::object::player
2945 player 3073 player
2946 3074
2947 cf::player 3075 cf::player
… …
2952 3080
2953=cut 3081=cut
2954 3082
2955for ( 3083for (
2956 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3084 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2957 insert remove inv name archname title slaying race 3085 insert remove inv nrof name archname title slaying race
2958 decrease_ob_nr destroy)], 3086 decrease split destroy change_exp)],
2959 ["cf::object::player" => qw(player)], 3087 ["cf::object::player" => qw(player)],
2960 ["cf::player" => qw(peaceful)], 3088 ["cf::player" => qw(peaceful)],
2961 ["cf::map" => qw(trigger)], 3089 ["cf::map" => qw(trigger)],
2962) { 3090) {
2963 no strict 'refs'; 3091 no strict 'refs';
… …
3068 { 3196 {
3069 my $faces = $facedata->{faceinfo}; 3197 my $faces = $facedata->{faceinfo};
3070 3198
3071 while (my ($face, $info) = each %$faces) { 3199 while (my ($face, $info) = each %$faces) {
3072 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3200 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3201
3073 cf::face::set_visibility $idx, $info->{visibility}; 3202 cf::face::set_visibility $idx, $info->{visibility};
3074 cf::face::set_magicmap $idx, $info->{magicmap}; 3203 cf::face::set_magicmap $idx, $info->{magicmap};
3075 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3204 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3076 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3205 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3077 3206
3078 cf::cede_to_tick; 3207 cf::cede_to_tick;
3079 } 3208 }
3080 3209
3081 while (my ($face, $info) = each %$faces) { 3210 while (my ($face, $info) = each %$faces) {
3082 next unless $info->{smooth}; 3211 next unless $info->{smooth};
3212
3083 my $idx = cf::face::find $face 3213 my $idx = cf::face::find $face
3084 or next; 3214 or next;
3215
3085 if (my $smooth = cf::face::find $info->{smooth}) { 3216 if (my $smooth = cf::face::find $info->{smooth}) {
3086 cf::face::set_smooth $idx, $smooth; 3217 cf::face::set_smooth $idx, $smooth;
3087 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3218 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3088 } else { 3219 } else {
3089 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3220 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
3107 { 3238 {
3108 # TODO: for gcfclient pleasure, we should give resources 3239 # TODO: for gcfclient pleasure, we should give resources
3109 # that gcfclient doesn't grok a >10000 face index. 3240 # that gcfclient doesn't grok a >10000 face index.
3110 my $res = $facedata->{resource}; 3241 my $res = $facedata->{resource};
3111 3242
3112 my $soundconf = delete $res->{"res/sound.conf"};
3113
3114 while (my ($name, $info) = each %$res) { 3243 while (my ($name, $info) = each %$res) {
3244 if (defined $info->{type}) {
3115 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3245 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3116 my $data; 3246 my $data;
3117 3247
3118 if ($info->{type} & 1) { 3248 if ($info->{type} & 1) {
3119 # prepend meta info 3249 # prepend meta info
3120 3250
3121 my $meta = $enc->encode ({ 3251 my $meta = $enc->encode ({
3122 name => $name, 3252 name => $name,
3123 %{ $info->{meta} || {} }, 3253 %{ $info->{meta} || {} },
3124 }); 3254 });
3125 3255
3126 $data = pack "(w/a*)*", $meta, $info->{data}; 3256 $data = pack "(w/a*)*", $meta, $info->{data};
3257 } else {
3258 $data = $info->{data};
3259 }
3260
3261 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3262 cf::face::set_type $idx, $info->{type};
3127 } else { 3263 } else {
3128 $data = $info->{data}; 3264 $RESOURCE{$name} = $info;
3129 } 3265 }
3130 3266
3131 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3132 cf::face::set_type $idx, $info->{type};
3133
3134 cf::cede_to_tick; 3267 cf::cede_to_tick;
3135 } 3268 }
3136
3137 if ($soundconf) {
3138 $soundconf = $enc->decode (delete $soundconf->{data});
3139
3140 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3141 my $sound = $soundconf->{compat}[$_]
3142 or next;
3143
3144 my $face = cf::face::find "sound/$sound->[1]";
3145 cf::sound::set $sound->[0] => $face;
3146 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3147 }
3148
3149 while (my ($k, $v) = each %{$soundconf->{event}}) {
3150 my $face = cf::face::find "sound/$v";
3151 cf::sound::set $k => $face;
3152 }
3153 }
3154 } 3269 }
3270
3271 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3155 3272
3156 1 3273 1
3157} 3274}
3275
3276cf::global->attach (on_resource_update => sub {
3277 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3278 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3279
3280 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3281 my $sound = $soundconf->{compat}[$_]
3282 or next;
3283
3284 my $face = cf::face::find "sound/$sound->[1]";
3285 cf::sound::set $sound->[0] => $face;
3286 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3287 }
3288
3289 while (my ($k, $v) = each %{$soundconf->{event}}) {
3290 my $face = cf::face::find "sound/$v";
3291 cf::sound::set $k => $face;
3292 }
3293 }
3294});
3158 3295
3159register_exticmd fx_want => sub { 3296register_exticmd fx_want => sub {
3160 my ($ns, $want) = @_; 3297 my ($ns, $want) = @_;
3161 3298
3162 while (my ($k, $v) = each %$want) { 3299 while (my ($k, $v) = each %$want) {
3163 $ns->fx_want ($k, $v); 3300 $ns->fx_want ($k, $v);
3164 } 3301 }
3165}; 3302};
3303
3304sub load_resource_file($) {
3305 my $guard = lock_acquire "load_resource_file";
3306
3307 my $status = load_resource_file_ $_[0];
3308 get_slot 0.1, 100;
3309 cf::arch::commit_load;
3310
3311 $status
3312}
3166 3313
3167sub reload_regions { 3314sub reload_regions {
3168 # HACK to clear player env face cache, we need some signal framework 3315 # HACK to clear player env face cache, we need some signal framework
3169 # for this (global event?) 3316 # for this (global event?)
3170 %ext::player_env::MUSIC_FACE_CACHE = (); 3317 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3184} 3331}
3185 3332
3186sub reload_archetypes { 3333sub reload_archetypes {
3187 load_resource_file "$DATADIR/archetypes" 3334 load_resource_file "$DATADIR/archetypes"
3188 or die "unable to load archetypes\n"; 3335 or die "unable to load archetypes\n";
3189 #d# NEED to laod twice to resolve forward references
3190 # this really needs to be done in an extra post-pass
3191 # (which needs to be synchronous, so solve it differently)
3192 load_resource_file "$DATADIR/archetypes"
3193 or die "unable to load archetypes\n";
3194} 3336}
3195 3337
3196sub reload_treasures { 3338sub reload_treasures {
3197 load_resource_file "$DATADIR/treasures" 3339 load_resource_file "$DATADIR/treasures"
3198 or die "unable to load treasurelists\n"; 3340 or die "unable to load treasurelists\n";
3199} 3341}
3200 3342
3201sub reload_resources { 3343sub reload_resources {
3202 warn "reloading resource files...\n"; 3344 warn "reloading resource files...\n";
3203 3345
3346 reload_facedata;
3347 reload_archetypes;
3204 reload_regions; 3348 reload_regions;
3205 reload_facedata;
3206 #reload_archetypes;#d#
3207 reload_archetypes;
3208 reload_treasures; 3349 reload_treasures;
3209 3350
3210 warn "finished reloading resource files\n"; 3351 warn "finished reloading resource files\n";
3211}
3212
3213sub init {
3214 reload_resources;
3215} 3352}
3216 3353
3217sub reload_config { 3354sub reload_config {
3218 open my $fh, "<:utf8", "$CONFDIR/config" 3355 open my $fh, "<:utf8", "$CONFDIR/config"
3219 or return; 3356 or return;
3220 3357
3221 local $/; 3358 local $/;
3222 *CFG = YAML::Syck::Load <$fh>; 3359 *CFG = YAML::Load <$fh>;
3223 3360
3224 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3361 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3225 3362
3226 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3363 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3227 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3364 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3233 }; 3370 };
3234 warn $@ if $@; 3371 warn $@ if $@;
3235 } 3372 }
3236} 3373}
3237 3374
3375sub pidfile() {
3376 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3377 or die "$PIDFILE: $!";
3378 flock $fh, &Fcntl::LOCK_EX
3379 or die "$PIDFILE: flock: $!";
3380 $fh
3381}
3382
3383# make sure only one server instance is running at any one time
3384sub atomic {
3385 my $fh = pidfile;
3386
3387 my $pid = <$fh>;
3388 kill 9, $pid if $pid > 0;
3389
3390 seek $fh, 0, 0;
3391 print $fh $$;
3392}
3393
3238sub main { 3394sub main {
3395 cf::init_globals; # initialise logging
3396
3397 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3398 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3399 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3400 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3401
3402 cf::init_experience;
3403 cf::init_anim;
3404 cf::init_attackmess;
3405 cf::init_dynamic;
3406 cf::init_block;
3407
3408 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3409
3239 # we must not ever block the main coroutine 3410 # we must not ever block the main coroutine
3240 local $Coro::idle = sub { 3411 local $Coro::idle = sub {
3241 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3412 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3242 (async { 3413 (async {
3243 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3414 $Coro::current->{desc} = "IDLE BUG HANDLER";
3244 Event::one_event; 3415 EV::loop EV::LOOP_ONESHOT;
3245 })->prio (Coro::PRIO_MAX); 3416 })->prio (Coro::PRIO_MAX);
3246 }; 3417 };
3247 3418
3419 evthread_start IO::AIO::poll_fileno;
3420
3421 cf::sync_job {
3422 reload_resources;
3248 reload_config; 3423 reload_config;
3249 db_init; 3424 db_init;
3425
3426 cf::load_settings;
3427 cf::load_materials;
3428 cf::init_uuid;
3429 cf::init_signals;
3430 cf::init_commands;
3431 cf::init_skills;
3432
3433 cf::init_beforeplay;
3434
3435 atomic;
3436
3250 load_extensions; 3437 load_extensions;
3251 3438
3252 $TICK_WATCHER->start; 3439 utime time, time, $RUNTIMEFILE;
3440
3441 # no (long-running) fork's whatsoever before this point(!)
3442 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3443
3444 (pop @POST_INIT)->(0) while @POST_INIT;
3445 };
3446
3253 Event::loop; 3447 EV::loop;
3254} 3448}
3255 3449
3256############################################################################# 3450#############################################################################
3257# initialisation and cleanup 3451# initialisation and cleanup
3258 3452
3259# install some emergency cleanup handlers 3453# install some emergency cleanup handlers
3260BEGIN { 3454BEGIN {
3455 our %SIGWATCHER = ();
3261 for my $signal (qw(INT HUP TERM)) { 3456 for my $signal (qw(INT HUP TERM)) {
3262 Event->signal ( 3457 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3263 reentrant => 0,
3264 data => WF_AUTOCANCEL,
3265 signal => $signal,
3266 prio => 0,
3267 cb => sub {
3268 cf::cleanup "SIG$signal"; 3458 cf::cleanup "SIG$signal";
3269 },
3270 ); 3459 };
3271 } 3460 }
3272} 3461}
3273 3462
3274sub write_runtime { 3463sub write_runtime_sync {
3275 my $runtime = "$LOCALDIR/runtime";
3276
3277 # first touch the runtime file to show we are still running: 3464 # first touch the runtime file to show we are still running:
3278 # the fsync below can take a very very long time. 3465 # the fsync below can take a very very long time.
3279 3466
3280 IO::AIO::aio_utime $runtime, undef, undef; 3467 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3281 3468
3282 my $guard = cf::lock_acquire "write_runtime"; 3469 my $guard = cf::lock_acquire "write_runtime";
3283 3470
3284 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3471 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3285 or return; 3472 or return;
3286 3473
3287 my $value = $cf::RUNTIME + 90 + 10; 3474 my $value = $cf::RUNTIME + 90 + 10;
3288 # 10 is the runtime save interval, for a monotonic clock 3475 # 10 is the runtime save interval, for a monotonic clock
3289 # 60 allows for the watchdog to kill the server. 3476 # 60 allows for the watchdog to kill the server.
… …
3299 aio_utime $fh, undef, undef; 3486 aio_utime $fh, undef, undef;
3300 3487
3301 close $fh 3488 close $fh
3302 or return; 3489 or return;
3303 3490
3304 aio_rename "$runtime~", $runtime 3491 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3305 and return; 3492 and return;
3306 3493
3307 warn "runtime file written.\n"; 3494 warn "runtime file written.\n";
3308 3495
3309 1 3496 1
3497}
3498
3499our $uuid_lock;
3500our $uuid_skip;
3501
3502sub write_uuid_sync($) {
3503 $uuid_skip ||= $_[0];
3504
3505 return if $uuid_lock;
3506 local $uuid_lock = 1;
3507
3508 my $uuid = "$LOCALDIR/uuid";
3509
3510 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3511 or return;
3512
3513 my $value = uuid_seq uuid_cur;
3514
3515 unless ($value) {
3516 warn "cowardly refusing to write zero uuid value!\n";
3517 return;
3518 }
3519
3520 my $value = uuid_str $value + $uuid_skip;
3521 $uuid_skip = 0;
3522
3523 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3524 and return;
3525
3526 # always fsync - this file is important
3527 aio_fsync $fh
3528 and return;
3529
3530 close $fh
3531 or return;
3532
3533 aio_rename "$uuid~", $uuid
3534 and return;
3535
3536 warn "uuid file written ($value).\n";
3537
3538 1
3539
3540}
3541
3542sub write_uuid($$) {
3543 my ($skip, $sync) = @_;
3544
3545 $sync ? write_uuid_sync $skip
3546 : async { write_uuid_sync $skip };
3310} 3547}
3311 3548
3312sub emergency_save() { 3549sub emergency_save() {
3313 my $freeze_guard = cf::freeze_mainloop; 3550 my $freeze_guard = cf::freeze_mainloop;
3314 3551
3315 warn "enter emergency perl save\n"; 3552 warn "emergency_perl_save: enter\n";
3316 3553
3317 cf::sync_job { 3554 cf::sync_job {
3555 # this is a trade-off: we want to be very quick here, so
3556 # save all maps without fsync, and later call a global sync
3557 # (which in turn might be very very slow)
3558 local $USE_FSYNC = 0;
3559
3318 # use a peculiar iteration method to avoid tripping on perl 3560 # use a peculiar iteration method to avoid tripping on perl
3319 # refcount bugs in for. also avoids problems with players 3561 # refcount bugs in for. also avoids problems with players
3320 # and maps saved/destroyed asynchronously. 3562 # and maps saved/destroyed asynchronously.
3321 warn "begin emergency player save\n"; 3563 warn "emergency_perl_save: begin player save\n";
3322 for my $login (keys %cf::PLAYER) { 3564 for my $login (keys %cf::PLAYER) {
3323 my $pl = $cf::PLAYER{$login} or next; 3565 my $pl = $cf::PLAYER{$login} or next;
3324 $pl->valid or next; 3566 $pl->valid or next;
3325 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3567 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3326 $pl->save; 3568 $pl->save;
3327 } 3569 }
3328 warn "end emergency player save\n"; 3570 warn "emergency_perl_save: end player save\n";
3329 3571
3330 warn "begin emergency map save\n"; 3572 warn "emergency_perl_save: begin map save\n";
3331 for my $path (keys %cf::MAP) { 3573 for my $path (keys %cf::MAP) {
3332 my $map = $cf::MAP{$path} or next; 3574 my $map = $cf::MAP{$path} or next;
3333 $map->valid or next; 3575 $map->valid or next;
3334 $map->save; 3576 $map->save;
3335 } 3577 }
3336 warn "end emergency map save\n"; 3578 warn "emergency_perl_save: end map save\n";
3337 3579
3338 warn "begin emergency database checkpoint\n"; 3580 warn "emergency_perl_save: begin database checkpoint\n";
3339 BDB::db_env_txn_checkpoint $DB_ENV; 3581 BDB::db_env_txn_checkpoint $DB_ENV;
3340 warn "end emergency database checkpoint\n"; 3582 warn "emergency_perl_save: end database checkpoint\n";
3583
3584 warn "emergency_perl_save: begin write uuid\n";
3585 write_uuid_sync 1;
3586 warn "emergency_perl_save: end write uuid\n";
3341 }; 3587 };
3342 3588
3589 warn "emergency_perl_save: starting sync()\n";
3590 IO::AIO::aio_sync sub {
3591 warn "emergency_perl_save: finished sync()\n";
3592 };
3593
3343 warn "leave emergency perl save\n"; 3594 warn "emergency_perl_save: leave\n";
3344} 3595}
3345 3596
3346sub post_cleanup { 3597sub post_cleanup {
3347 my ($make_core) = @_; 3598 my ($make_core) = @_;
3348 3599
3349 warn Carp::longmess "post_cleanup backtrace" 3600 warn Carp::longmess "post_cleanup backtrace"
3350 if $make_core; 3601 if $make_core;
3602
3603 my $fh = pidfile;
3604 unlink $PIDFILE if <$fh> == $$;
3605}
3606
3607# a safer delete_package, copied from Symbol
3608sub clear_package($) {
3609 my $pkg = shift;
3610
3611 # expand to full symbol table name if needed
3612 unless ($pkg =~ /^main::.*::$/) {
3613 $pkg = "main$pkg" if $pkg =~ /^::/;
3614 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3615 $pkg .= '::' unless $pkg =~ /::$/;
3616 }
3617
3618 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3619 my $stem_symtab = *{$stem}{HASH};
3620
3621 defined $stem_symtab and exists $stem_symtab->{$leaf}
3622 or return;
3623
3624 # clear all symbols
3625 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3626 for my $name (keys %$leaf_symtab) {
3627 _gv_clear *{"$pkg$name"};
3628# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3629 }
3630 warn "cleared package $pkg\n";#d#
3351} 3631}
3352 3632
3353sub do_reload_perl() { 3633sub do_reload_perl() {
3354 # can/must only be called in main 3634 # can/must only be called in main
3355 if ($Coro::current != $Coro::main) { 3635 if ($Coro::current != $Coro::main) {
3356 warn "can only reload from main coroutine"; 3636 warn "can only reload from main coroutine";
3357 return; 3637 return;
3358 } 3638 }
3359 3639
3640 return if $RELOAD++;
3641
3642 my $t1 = EV::time;
3643
3644 while ($RELOAD) {
3360 warn "reloading..."; 3645 warn "reloading...";
3361 3646
3362 warn "entering sync_job"; 3647 warn "entering sync_job";
3363 3648
3364 cf::sync_job { 3649 cf::sync_job {
3365 cf::write_runtime; # external watchdog should not bark 3650 cf::write_runtime_sync; # external watchdog should not bark
3366 cf::emergency_save; 3651 cf::emergency_save;
3367 cf::write_runtime; # external watchdog should not bark 3652 cf::write_runtime_sync; # external watchdog should not bark
3368 3653
3369 warn "syncing database to disk"; 3654 warn "syncing database to disk";
3370 BDB::db_env_txn_checkpoint $DB_ENV; 3655 BDB::db_env_txn_checkpoint $DB_ENV;
3371 3656
3372 # if anything goes wrong in here, we should simply crash as we already saved 3657 # if anything goes wrong in here, we should simply crash as we already saved
3373 3658
3374 warn "cancelling all WF_AUTOCANCEL watchers";
3375 for (Event::all_watchers) {
3376 $_->cancel if $_->data & WF_AUTOCANCEL;
3377 }
3378
3379 warn "flushing outstanding aio requests"; 3659 warn "flushing outstanding aio requests";
3380 for (;;) {
3381 BDB::flush;
3382 IO::AIO::flush;
3383 Coro::cede_notself;
3384 last unless IO::AIO::nreqs || BDB::nreqs; 3660 while (IO::AIO::nreqs || BDB::nreqs) {
3385 warn "iterate..."; 3661 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3386 }
3387
3388 ++$RELOAD;
3389
3390 warn "cancelling all extension coros";
3391 $_->cancel for values %EXT_CORO;
3392 %EXT_CORO = ();
3393
3394 warn "removing commands";
3395 %COMMAND = ();
3396
3397 warn "removing ext/exti commands";
3398 %EXTCMD = ();
3399 %EXTICMD = ();
3400
3401 warn "unloading/nuking all extensions";
3402 for my $pkg (@EXTS) {
3403 warn "... unloading $pkg";
3404
3405 if (my $cb = $pkg->can ("unload")) {
3406 eval {
3407 $cb->($pkg);
3408 1
3409 } or warn "$pkg unloaded, but with errors: $@";
3410 } 3662 }
3411 3663
3412 warn "... nuking $pkg"; 3664 warn "cancelling all extension coros";
3413 Symbol::delete_package $pkg; 3665 $_->cancel for values %EXT_CORO;
3414 } 3666 %EXT_CORO = ();
3415 3667
3416 warn "unloading all perl modules loaded from $LIBDIR"; 3668 warn "removing commands";
3417 while (my ($k, $v) = each %INC) { 3669 %COMMAND = ();
3418 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3419 3670
3671 warn "removing ext/exti commands";
3672 %EXTCMD = ();
3673 %EXTICMD = ();
3674
3675 warn "unloading/nuking all extensions";
3676 for my $pkg (@EXTS) {
3420 warn "... unloading $k"; 3677 warn "... unloading $pkg";
3421 delete $INC{$k};
3422 3678
3423 $k =~ s/\.pm$//;
3424 $k =~ s/\//::/g;
3425
3426 if (my $cb = $k->can ("unload_module")) { 3679 if (my $cb = $pkg->can ("unload")) {
3680 eval {
3427 $cb->(); 3681 $cb->($pkg);
3682 1
3683 } or warn "$pkg unloaded, but with errors: $@";
3684 }
3685
3686 warn "... clearing $pkg";
3687 clear_package $pkg;
3428 } 3688 }
3429 3689
3430 Symbol::delete_package $k; 3690 warn "unloading all perl modules loaded from $LIBDIR";
3691 while (my ($k, $v) = each %INC) {
3692 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3693
3694 warn "... unloading $k";
3695 delete $INC{$k};
3696
3697 $k =~ s/\.pm$//;
3698 $k =~ s/\//::/g;
3699
3700 if (my $cb = $k->can ("unload_module")) {
3701 $cb->();
3702 }
3703
3704 clear_package $k;
3431 } 3705 }
3432 3706
3433 warn "getting rid of safe::, as good as possible"; 3707 warn "getting rid of safe::, as good as possible";
3434 Symbol::delete_package "safe::$_" 3708 clear_package "safe::$_"
3435 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3709 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3436 3710
3437 warn "unloading cf.pm \"a bit\""; 3711 warn "unloading cf.pm \"a bit\"";
3438 delete $INC{"cf.pm"}; 3712 delete $INC{"cf.pm"};
3439 delete $INC{"cf/pod.pm"}; 3713 delete $INC{"cf/pod.pm"};
3440 3714
3441 # don't, removes xs symbols, too, 3715 # don't, removes xs symbols, too,
3442 # and global variables created in xs 3716 # and global variables created in xs
3443 #Symbol::delete_package __PACKAGE__; 3717 #clear_package __PACKAGE__;
3444 3718
3445 warn "unload completed, starting to reload now"; 3719 warn "unload completed, starting to reload now";
3446 3720
3447 warn "reloading cf.pm"; 3721 warn "reloading cf.pm";
3448 require cf; 3722 require cf;
3449 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3723 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3450 3724
3451 warn "loading config and database again"; 3725 warn "loading config and database again";
3452 cf::reload_config; 3726 cf::reload_config;
3453 3727
3454 warn "loading extensions"; 3728 warn "loading extensions";
3455 cf::load_extensions; 3729 cf::load_extensions;
3456 3730
3731 if ($REATTACH_ON_RELOAD) {
3457 warn "reattaching attachments to objects/players"; 3732 warn "reattaching attachments to objects/players";
3458 _global_reattach; # objects, sockets 3733 _global_reattach; # objects, sockets
3459 warn "reattaching attachments to maps"; 3734 warn "reattaching attachments to maps";
3460 reattach $_ for values %MAP; 3735 reattach $_ for values %MAP;
3461 warn "reattaching attachments to players"; 3736 warn "reattaching attachments to players";
3462 reattach $_ for values %PLAYER; 3737 reattach $_ for values %PLAYER;
3738 }
3463 3739
3740 warn "running post_init jobs";
3741 (pop @POST_INIT)->(1) while @POST_INIT;
3742
3464 warn "leaving sync_job"; 3743 warn "leaving sync_job";
3465 3744
3466 1 3745 1
3467 } or do { 3746 } or do {
3468 warn $@; 3747 warn $@;
3469 warn "error while reloading, exiting."; 3748 cf::cleanup "error while reloading, exiting.";
3470 exit 1;
3471 }; 3749 };
3472 3750
3473 warn "reloaded"; 3751 warn "reloaded";
3752 --$RELOAD;
3753 }
3754
3755 $t1 = EV::time - $t1;
3756 warn "reload completed in ${t1}s\n";
3474}; 3757};
3475 3758
3476our $RELOAD_WATCHER; # used only during reload 3759our $RELOAD_WATCHER; # used only during reload
3477 3760
3478sub reload_perl() { 3761sub reload_perl() {
3479 # doing reload synchronously and two reloads happen back-to-back, 3762 # doing reload synchronously and two reloads happen back-to-back,
3480 # coro crashes during coro_state_free->destroy here. 3763 # coro crashes during coro_state_free->destroy here.
3481 3764
3482 $RELOAD_WATCHER ||= Event->timer ( 3765 $RELOAD_WATCHER ||= cf::async {
3483 reentrant => 0, 3766 Coro::AIO::aio_wait cache_extensions;
3484 after => 0, 3767
3485 data => WF_AUTOCANCEL, 3768 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3486 cb => sub {
3487 do_reload_perl; 3769 do_reload_perl;
3488 undef $RELOAD_WATCHER; 3770 undef $RELOAD_WATCHER;
3489 }, 3771 };
3490 ); 3772 };
3491} 3773}
3492 3774
3493register_command "reload" => sub { 3775register_command "reload" => sub {
3494 my ($who, $arg) = @_; 3776 my ($who, $arg) = @_;
3495 3777
… …
3508 3790
3509our @WAIT_FOR_TICK; 3791our @WAIT_FOR_TICK;
3510our @WAIT_FOR_TICK_BEGIN; 3792our @WAIT_FOR_TICK_BEGIN;
3511 3793
3512sub wait_for_tick { 3794sub wait_for_tick {
3513 return unless $TICK_WATCHER->is_active;
3514 return if $Coro::current == $Coro::main; 3795 return if tick_inhibit || $Coro::current == $Coro::main;
3515 3796
3516 my $signal = new Coro::Signal; 3797 my $signal = new Coro::Signal;
3517 push @WAIT_FOR_TICK, $signal; 3798 push @WAIT_FOR_TICK, $signal;
3518 $signal->wait; 3799 $signal->wait;
3519} 3800}
3520 3801
3521sub wait_for_tick_begin { 3802sub wait_for_tick_begin {
3522 return unless $TICK_WATCHER->is_active;
3523 return if $Coro::current == $Coro::main; 3803 return if tick_inhibit || $Coro::current == $Coro::main;
3524 3804
3525 my $signal = new Coro::Signal; 3805 my $signal = new Coro::Signal;
3526 push @WAIT_FOR_TICK_BEGIN, $signal; 3806 push @WAIT_FOR_TICK_BEGIN, $signal;
3527 $signal->wait; 3807 $signal->wait;
3528} 3808}
3529 3809
3530$TICK_WATCHER = Event->timer ( 3810sub tick {
3531 reentrant => 0,
3532 parked => 1,
3533 prio => 0,
3534 at => $NEXT_TICK || $TICK,
3535 data => WF_AUTOCANCEL,
3536 cb => sub {
3537 if ($Coro::current != $Coro::main) { 3811 if ($Coro::current != $Coro::main) {
3538 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3812 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3539 unless ++$bug_warning > 10; 3813 unless ++$bug_warning > 10;
3540 return; 3814 return;
3541 } 3815 }
3542 3816
3543 $NOW = $tick_start = Event::time;
3544
3545 cf::server_tick; # one server iteration 3817 cf::server_tick; # one server iteration
3546 3818
3547 $RUNTIME += $TICK;
3548 $NEXT_TICK += $TICK;
3549
3550 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3819 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3551 $NEXT_RUNTIME_WRITE = $NOW + 10; 3820 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3552 Coro::async_pool { 3821 Coro::async_pool {
3553 $Coro::current->{desc} = "runtime saver"; 3822 $Coro::current->{desc} = "runtime saver";
3554 write_runtime 3823 write_runtime_sync
3555 or warn "ERROR: unable to write runtime file: $!"; 3824 or warn "ERROR: unable to write runtime file: $!";
3556 };
3557 } 3825 };
3826 }
3558 3827
3559 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3828 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3560 $sig->send; 3829 $sig->send;
3561 } 3830 }
3562 while (my $sig = shift @WAIT_FOR_TICK) { 3831 while (my $sig = shift @WAIT_FOR_TICK) {
3563 $sig->send; 3832 $sig->send;
3564 } 3833 }
3565 3834
3566 $NOW = Event::time; 3835 $LOAD = ($NOW - $TICK_START) / $TICK;
3567
3568 # if we are delayed by four ticks or more, skip them all
3569 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3570
3571 $TICK_WATCHER->at ($NEXT_TICK);
3572 $TICK_WATCHER->start;
3573
3574 $LOAD = ($NOW - $tick_start) / $TICK;
3575 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3836 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3576 3837
3577 _post_tick; 3838 if (0) {
3839 if ($NEXT_TICK) {
3840 my $jitter = $TICK_START - $NEXT_TICK;
3841 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3842 warn "jitter $JITTER\n";#d#
3843 }
3578 }, 3844 }
3579); 3845}
3580 3846
3581{ 3847{
3848 # configure BDB
3849
3582 BDB::min_parallel 8; 3850 BDB::min_parallel 8;
3583 BDB::max_poll_time $TICK * 0.1; 3851 BDB::max_poll_reqs $TICK * 0.1;
3584 $BDB_POLL_WATCHER = Event->io ( 3852 $AnyEvent::BDB::WATCHER->priority (1);
3585 reentrant => 0,
3586 fd => BDB::poll_fileno,
3587 poll => 'r',
3588 prio => 0,
3589 data => WF_AUTOCANCEL,
3590 cb => \&BDB::poll_cb,
3591 );
3592
3593 BDB::set_sync_prepare {
3594 my $status;
3595 my $current = $Coro::current;
3596 (
3597 sub {
3598 $status = $!;
3599 $current->ready; undef $current;
3600 },
3601 sub {
3602 Coro::schedule while defined $current;
3603 $! = $status;
3604 },
3605 )
3606 };
3607 3853
3608 unless ($DB_ENV) { 3854 unless ($DB_ENV) {
3609 $DB_ENV = BDB::db_env_create; 3855 $DB_ENV = BDB::db_env_create;
3610 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 3856 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3611 | BDB::LOG_AUTOREMOVE, 1); 3857 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3858 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3612 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 3859 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3613 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 3860 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3614 3861
3615 cf::sync_job { 3862 cf::sync_job {
3616 eval { 3863 eval {
… …
3626 3873
3627 cf::cleanup "db_env_open(db): $@" if $@; 3874 cf::cleanup "db_env_open(db): $@" if $@;
3628 }; 3875 };
3629 } 3876 }
3630 3877
3631 $BDB_DEADLOCK_WATCHER = Event->timer ( 3878 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3632 after => 3,
3633 interval => 1,
3634 hard => 1,
3635 prio => 0,
3636 data => WF_AUTOCANCEL,
3637 cb => sub {
3638 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 3879 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3639 },
3640 ); 3880 };
3641 $BDB_CHECKPOINT_WATCHER = Event->timer ( 3881 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3642 after => 11,
3643 interval => 60,
3644 hard => 1,
3645 prio => 0,
3646 data => WF_AUTOCANCEL,
3647 cb => sub {
3648 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { }; 3882 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3649 },
3650 ); 3883 };
3651 $BDB_TRICKLE_WATCHER = Event->timer ( 3884 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3652 after => 5,
3653 interval => 10,
3654 hard => 1,
3655 prio => 0,
3656 data => WF_AUTOCANCEL,
3657 cb => sub {
3658 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { }; 3885 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3659 },
3660 ); 3886 };
3661} 3887}
3662 3888
3663{ 3889{
3890 # configure IO::AIO
3891
3664 IO::AIO::min_parallel 8; 3892 IO::AIO::min_parallel 8;
3665
3666 undef $Coro::AIO::WATCHER;
3667 IO::AIO::max_poll_time $TICK * 0.1; 3893 IO::AIO::max_poll_time $TICK * 0.1;
3668 $AIO_POLL_WATCHER = Event->io ( 3894 undef $AnyEvent::AIO::WATCHER;
3669 reentrant => 0,
3670 data => WF_AUTOCANCEL,
3671 fd => IO::AIO::poll_fileno,
3672 poll => 'r',
3673 prio => 0,
3674 cb => \&IO::AIO::poll_cb,
3675 );
3676} 3895}
3677 3896
3678my $_log_backtrace; 3897my $_log_backtrace;
3679 3898
3680sub _log_backtrace { 3899sub _log_backtrace {
… …
3683 $msg =~ s/\n//; 3902 $msg =~ s/\n//;
3684 3903
3685 # limit the # of concurrent backtraces 3904 # limit the # of concurrent backtraces
3686 if ($_log_backtrace < 2) { 3905 if ($_log_backtrace < 2) {
3687 ++$_log_backtrace; 3906 ++$_log_backtrace;
3907 my $perl_bt = Carp::longmess $msg;
3688 async { 3908 async {
3689 $Coro::current->{desc} = "abt $msg"; 3909 $Coro::current->{desc} = "abt $msg";
3690 3910
3691 my @bt = fork_call { 3911 my @bt = fork_call {
3692 @addr = map { sprintf "%x", $_ } @addr; 3912 @addr = map { sprintf "%x", $_ } @addr;
… …
3703 } 3923 }
3704 3924
3705 @funcs 3925 @funcs
3706 }; 3926 };
3707 3927
3708 LOG llevInfo, "[ABT] $msg\n"; 3928 LOG llevInfo, "[ABT] $perl_bt\n";
3929 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3709 LOG llevInfo, "[ABT] $_\n" for @bt; 3930 LOG llevInfo, "[ABT] $_\n" for @bt;
3710 --$_log_backtrace; 3931 --$_log_backtrace;
3711 }; 3932 };
3712 } else { 3933 } else {
3713 LOG llevInfo, "[ABT] $msg\n"; 3934 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

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