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

Diff Legend

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