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

Diff Legend

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