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

Diff Legend

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