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.278 by root, Mon Jun 11 21:38:14 2007 UTC vs.
Revision 1.446 by root, Tue Sep 16 16:03:02 2008 UTC

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

Diff Legend

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