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.263 by root, Sat May 5 05:40:27 2007 UTC vs.
Revision 1.443 by root, Sun Aug 31 10:05:26 2008 UTC

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

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines