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.275 by root, Thu Jun 7 19:12:22 2007 UTC vs.
Revision 1.445 by root, Wed Sep 10 18:18:10 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;
945 }, 1312 },
946); 1313);
947 1314
948sub load_extension {
949 my ($path) = @_;
950
951 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
952 my $base = $1;
953 my $pkg = $1;
954 $pkg =~ s/[^[:word:]]/_/g;
955 $pkg = "ext::$pkg";
956
957 warn "... loading '$path' into '$pkg'\n";
958
959 open my $fh, "<:utf8", $path
960 or die "$path: $!";
961
962 my $source =
963 "package $pkg; use strict; use utf8;\n"
964 . "#line 1 \"$path\"\n{\n"
965 . (do { local $/; <$fh> })
966 . "\n};\n1";
967
968 unless (eval $source) {
969 my $msg = $@ ? "$path: $@\n"
970 : "extension disabled.\n";
971 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
972 warn $@;
973 warn "mandatory extension failed to load, exiting.\n";
974 exit 1;
975 }
976 die $@;
977 }
978
979 push @EXTS, $pkg;
980}
981
982sub load_extensions { 1315sub load_extensions {
1316 cf::sync_job {
1317 my %todo;
1318
983 for my $ext (<$LIBDIR/*.ext>) { 1319 for my $path (<$LIBDIR/*.ext>) {
984 next unless -r $ext; 1320 next unless -r $path;
985 eval { 1321
986 load_extension $ext; 1322 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1323 my $base = $1;
1324 my $pkg = $1;
1325 $pkg =~ s/[^[:word:]]/_/g;
1326 $pkg = "ext::$pkg";
1327
1328 open my $fh, "<:utf8", $path
1329 or die "$path: $!";
1330
1331 my $source = do { local $/; <$fh> };
1332
1333 my %ext = (
1334 path => $path,
1335 base => $base,
1336 pkg => $pkg,
1337 );
1338
1339 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1340 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1341
1342 $ext{source} =
1343 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1344 . "#line 1 \"$path\"\n{\n"
1345 . $source
1346 . "\n};\n1";
1347
1348 $todo{$base} = \%ext;
1349 }
1350
1351 my %done;
1352 while (%todo) {
1353 my $progress;
1354
1355 while (my ($k, $v) = each %todo) {
1356 for (split /,\s*/, $v->{meta}{depends}) {
1357 goto skip
1358 unless exists $done{$_};
1359 }
1360
1361 warn "... loading '$k' into '$v->{pkg}'\n";
1362
1363 unless (eval $v->{source}) {
1364 my $msg = $@ ? "$v->{path}: $@\n"
1365 : "$v->{base}: extension inactive.\n";
1366
1367 if (exists $v->{meta}{mandatory}) {
1368 warn $msg;
1369 cf::cleanup "mandatory extension failed to load, exiting.";
1370 }
1371
1372 warn $msg;
1373 }
1374
1375 $done{$k} = delete $todo{$k};
1376 push @EXTS, $v->{pkg};
1377 $progress = 1;
987 1 1378 }
988 } or warn "$ext not loaded: $@"; 1379
1380 skip:
1381 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1382 unless $progress;
1383 }
989 } 1384 };
990} 1385}
991 1386
992############################################################################# 1387#############################################################################
993 1388
1389=back
1390
994=head2 CORE EXTENSIONS 1391=head2 CORE EXTENSIONS
995 1392
996Functions and methods that extend core crossfire objects. 1393Functions and methods that extend core crossfire objects.
997 1394
998=cut 1395=cut
… …
1002use Coro::AIO; 1399use Coro::AIO;
1003 1400
1004=head3 cf::player 1401=head3 cf::player
1005 1402
1006=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}
1007 1418
1008=item cf::player::find $login 1419=item cf::player::find $login
1009 1420
1010Returns the given player object, loading it if necessary (might block). 1421Returns the given player object, loading it if necessary (might block).
1011 1422
… …
1047 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1458 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1048 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1459 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1049 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1460 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1050 aio_unlink +(playerdir $login) . "/$login.pl"; 1461 aio_unlink +(playerdir $login) . "/$login.pl";
1051 1462
1052 my $pl = load_pl path $login 1463 my $f = new_from_file cf::object::thawer path $login
1053 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;
1054 $cf::PLAYER{$login} = $pl 1471 $cf::PLAYER{$login} = $pl
1055 } 1472 }
1056 } 1473 }
1057} 1474}
1058 1475
… …
1067 return if $pl->{deny_save}; 1484 return if $pl->{deny_save};
1068 1485
1069 aio_mkdir playerdir $pl, 0770; 1486 aio_mkdir playerdir $pl, 0770;
1070 $pl->{last_save} = $cf::RUNTIME; 1487 $pl->{last_save} = $cf::RUNTIME;
1071 1488
1489 cf::get_slot 0.01;
1490
1072 $pl->save_pl ($path); 1491 $pl->save_pl ($path);
1073 Coro::cede; 1492 cf::cede_to_tick;
1074} 1493}
1075 1494
1076sub new($) { 1495sub new($) {
1077 my ($login) = @_; 1496 my ($login) = @_;
1078 1497
… …
1084 $cf::PLAYER{$login} = $self; 1503 $cf::PLAYER{$login} = $self;
1085 1504
1086 $self 1505 $self
1087} 1506}
1088 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
1089=item $pl->quit_character 1518=item $pl->quit_character
1090 1519
1091Nukes the player without looking back. If logged in, the connection will 1520Nukes the player without looking back. If logged in, the connection will
1092be destroyed. May block for a long time. 1521be destroyed. May block for a long time.
1093 1522
… …
1097 my ($pl) = @_; 1526 my ($pl) = @_;
1098 1527
1099 my $name = $pl->ob->name; 1528 my $name = $pl->ob->name;
1100 1529
1101 $pl->{deny_save} = 1; 1530 $pl->{deny_save} = 1;
1102 $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
1103 1532
1104 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1533 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1105 $pl->deactivate; 1534 $pl->deactivate;
1535 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1536 $pl->ob->check_score;
1106 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1537 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1107 $pl->ns->destroy if $pl->ns; 1538 $pl->ns->destroy if $pl->ns;
1108 1539
1109 my $path = playerdir $pl; 1540 my $path = playerdir $pl;
1110 my $temp = "$path~$cf::RUNTIME~deleting~"; 1541 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1146 or return []; 1577 or return [];
1147 1578
1148 my @logins; 1579 my @logins;
1149 1580
1150 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") {
1151 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1587 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1152 aio_read $fh, 0, 512, my $buf, 0 or next; 1588 aio_read $fh, 0, 512, my $buf, 0 or next;
1153 $buf !~ /^password -------------$/m or next; # official not-valid tag 1589 $buf !~ /^password -------------$/m or next; # official not-valid tag
1590 }
1154 1591
1155 utf8::decode $login; 1592 utf8::decode $login;
1156 push @logins, $login; 1593 push @logins, $login;
1157 } 1594 }
1158 1595
… …
1185 } 1622 }
1186 1623
1187 \@paths 1624 \@paths
1188} 1625}
1189 1626
1627=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1628
1629Expand crossfire pod fragments into protocol xml.
1630
1190=item $player->ext_reply ($msgid, %msg) 1631=item $player->ext_reply ($msgid, @msg)
1191 1632
1192Sends an ext reply to the player. 1633Sends an ext reply to the player.
1193 1634
1194=cut 1635=cut
1195 1636
1196sub ext_reply($$%) { 1637sub ext_reply($$@) {
1197 my ($self, $id, %msg) = @_; 1638 my ($self, $id, @msg) = @_;
1198 1639
1199 $msg{msgid} = $id; 1640 $self->ns->ext_reply ($id, @msg)
1200
1201 $self->send ("ext " . cf::to_json \%msg);
1202} 1641}
1203 1642
1204=item $player->ext_event ($type, %msg) 1643=item $player->ext_msg ($type, @msg)
1205 1644
1206Sends an ext event to the client. 1645Sends an ext event to the client.
1207 1646
1208=cut 1647=cut
1209 1648
1210sub ext_event($$%) { 1649sub ext_msg($$@) {
1211 my ($self, $type, %msg) = @_; 1650 my ($self, $type, @msg) = @_;
1212 1651
1213 $self->ns->ext_event ($type, %msg); 1652 $self->ns->ext_msg ($type, @msg);
1214} 1653}
1215 1654
1216=head3 cf::region 1655=head3 cf::region
1217 1656
1218=over 4 1657=over 4
… …
1221 1660
1222package cf::region; 1661package cf::region;
1223 1662
1224=item cf::region::find_by_path $path 1663=item cf::region::find_by_path $path
1225 1664
1226Tries 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.
1227 1666
1228=cut 1667=cut
1229 1668
1230sub find_by_path($) { 1669sub find_by_path($) {
1231 my ($path) = @_; 1670 my ($path) = @_;
1232 1671
1233 my ($match, $specificity); 1672 my ($match, $specificity);
1234 1673
1235 for my $region (list) { 1674 for my $region (list) {
1236 if ($region->match && $path =~ $region->match) { 1675 if ($region->{match} && $path =~ $region->{match}) {
1237 ($match, $specificity) = ($region, $region->specificity) 1676 ($match, $specificity) = ($region, $region->specificity)
1238 if $region->specificity > $specificity; 1677 if $region->specificity > $specificity;
1239 } 1678 }
1240 } 1679 }
1241 1680
… …
1262our $MAX_RESET = 3600; 1701our $MAX_RESET = 3600;
1263our $DEFAULT_RESET = 3000; 1702our $DEFAULT_RESET = 3000;
1264 1703
1265sub generate_random_map { 1704sub generate_random_map {
1266 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
1267 # mit "rum" bekleckern, nicht 1709 # mit "rum" bekleckern, nicht
1268 $self->_create_random_map ( 1710 $self->_create_random_map (
1269 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1711 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1270 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1712 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1271 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1713 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1361 $self->init; # pass $1 etc. 1803 $self->init; # pass $1 etc.
1362 return $self; 1804 return $self;
1363 } 1805 }
1364 } 1806 }
1365 1807
1366 Carp::carp "unable to resolve path '$path' (base '$base')."; 1808 Carp::cluck "unable to resolve path '$path' (base '$base').";
1367 () 1809 ()
1368} 1810}
1369 1811
1370sub init { 1812sub init {
1371 my ($self) = @_; 1813 my ($self) = @_;
… …
1393 1835
1394# the temporary/swap location 1836# the temporary/swap location
1395sub save_path { 1837sub save_path {
1396 my ($self) = @_; 1838 my ($self) = @_;
1397 1839
1398 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1840 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1399 "$TMPDIR/$path.map" 1841 "$TMPDIR/$path.map"
1400} 1842}
1401 1843
1402# the unique path, undef == no special unique path 1844# the unique path, undef == no special unique path
1403sub uniq_path { 1845sub uniq_path {
1404 my ($self) = @_; 1846 my ($self) = @_;
1405 1847
1406 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1848 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1407 "$UNIQUEDIR/$path" 1849 "$UNIQUEDIR/$path"
1408} 1850}
1409 1851
1410# and all this just because we cannot iterate over 1852# and all this just because we cannot iterate over
1411# all maps in C++... 1853# all maps in C++...
… …
1434 1876
1435sub load_header_from($) { 1877sub load_header_from($) {
1436 my ($self, $path) = @_; 1878 my ($self, $path) = @_;
1437 1879
1438 utf8::encode $path; 1880 utf8::encode $path;
1439 #aio_open $path, O_RDONLY, 0 1881 my $f = new_from_file cf::object::thawer $path
1440 # or return;
1441
1442 $self->_load_header ($path)
1443 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;
1444 1889
1445 $self->{load_path} = $path; 1890 $self->{load_path} = $path;
1446 1891
1447 1 1892 1
1448} 1893}
… …
1502sub find { 1947sub find {
1503 my ($path, $origin) = @_; 1948 my ($path, $origin) = @_;
1504 1949
1505 $path = normalise $path, $origin && $origin->path; 1950 $path = normalise $path, $origin && $origin->path;
1506 1951
1952 cf::lock_wait "map_data:$path";#d#remove
1507 cf::lock_wait "map_find:$path"; 1953 cf::lock_wait "map_find:$path";
1508 1954
1509 $cf::MAP{$path} || do { 1955 $cf::MAP{$path} || do {
1956 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1510 my $guard = cf::lock_acquire "map_find:$path"; 1957 my $guard2 = cf::lock_acquire "map_find:$path";
1958
1511 my $map = new_from_path cf::map $path 1959 my $map = new_from_path cf::map $path
1512 or return; 1960 or return;
1513 1961
1514 $map->{last_save} = $cf::RUNTIME; 1962 $map->{last_save} = $cf::RUNTIME;
1515 1963
… …
1517 or return; 1965 or return;
1518 1966
1519 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1967 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1520 # doing this can freeze the server in a sync job, obviously 1968 # doing this can freeze the server in a sync job, obviously
1521 #$cf::WAIT_FOR_TICK->wait; 1969 #$cf::WAIT_FOR_TICK->wait;
1970 undef $guard2;
1971 undef $guard1;
1522 $map->reset; 1972 $map->reset;
1523 undef $guard;
1524 return find $path; 1973 return find $path;
1525 } 1974 }
1526 1975
1527 $cf::MAP{$path} = $map 1976 $cf::MAP{$path} = $map
1528 } 1977 }
… …
1537 local $self->{deny_reset} = 1; # loading can take a long time 1986 local $self->{deny_reset} = 1; # loading can take a long time
1538 1987
1539 my $path = $self->{path}; 1988 my $path = $self->{path};
1540 1989
1541 { 1990 {
1542 my $guard = cf::lock_acquire "map_load:$path"; 1991 my $guard = cf::lock_acquire "map_data:$path";
1543 1992
1993 return unless $self->valid;
1544 return if $self->in_memory != cf::MAP_SWAPPED; 1994 return unless $self->in_memory == cf::MAP_SWAPPED;
1545 1995
1546 $self->in_memory (cf::MAP_LOADING); 1996 $self->in_memory (cf::MAP_LOADING);
1547 1997
1548 $self->alloc; 1998 $self->alloc;
1549 1999
1550 $self->pre_load; 2000 $self->pre_load;
1551 Coro::cede; 2001 cf::cede_to_tick;
1552 2002
2003 my $f = new_from_file cf::object::thawer $self->{load_path};
2004 $f->skip_block;
1553 $self->_load_objects ($self->{load_path}, 1) 2005 $self->_load_objects ($f)
1554 or return; 2006 or return;
1555 2007
1556 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2008 $self->post_load_original
1557 if delete $self->{load_original}; 2009 if delete $self->{load_original};
1558 2010
1559 if (my $uniq = $self->uniq_path) { 2011 if (my $uniq = $self->uniq_path) {
1560 utf8::encode $uniq; 2012 utf8::encode $uniq;
1561 if (aio_open $uniq, O_RDONLY, 0) { 2013 unless (aio_stat $uniq) {
2014 if (my $f = new_from_file cf::object::thawer $uniq) {
1562 $self->clear_unique_items; 2015 $self->clear_unique_items;
1563 $self->_load_objects ($uniq, 0); 2016 $self->_load_objects ($f);
2017 $f->resolve_delayed_derefs;
2018 }
1564 } 2019 }
1565 } 2020 }
1566 2021
1567 Coro::cede; 2022 $f->resolve_delayed_derefs;
2023
2024 cf::cede_to_tick;
1568 # now do the right thing for maps 2025 # now do the right thing for maps
1569 $self->link_multipart_objects; 2026 $self->link_multipart_objects;
1570 $self->difficulty ($self->estimate_difficulty) 2027 $self->difficulty ($self->estimate_difficulty)
1571 unless $self->difficulty; 2028 unless $self->difficulty;
1572 Coro::cede; 2029 cf::cede_to_tick;
1573 2030
1574 unless ($self->{deny_activate}) { 2031 unless ($self->{deny_activate}) {
1575 $self->decay_objects; 2032 $self->decay_objects;
1576 $self->fix_auto_apply; 2033 $self->fix_auto_apply;
1577 $self->update_buttons; 2034 $self->update_buttons;
1578 Coro::cede; 2035 cf::cede_to_tick;
1579 $self->set_darkness_map; 2036 $self->set_darkness_map;
1580 Coro::cede; 2037 cf::cede_to_tick;
1581 $self->activate; 2038 $self->activate;
1582 } 2039 }
1583 2040
2041 $self->{last_save} = $cf::RUNTIME;
2042 $self->last_access ($cf::RUNTIME);
2043
1584 $self->in_memory (cf::MAP_IN_MEMORY); 2044 $self->in_memory (cf::MAP_ACTIVE);
1585 } 2045 }
1586 2046
1587 $self->post_load; 2047 $self->post_load;
1588} 2048}
1589 2049
… …
1598 2058
1599 $self 2059 $self
1600} 2060}
1601 2061
1602# 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
1603sub load_diag { 2063sub load_neighbours {
1604 my ($map) = @_; 2064 my ($map) = @_;
1605 2065
1606 my @diag; # diagonal neighbours 2066 my @neigh; # diagonal neighbours
1607 2067
1608 for (0 .. 3) { 2068 for (0 .. 3) {
1609 my $neigh = $map->tile_path ($_) 2069 my $neigh = $map->tile_path ($_)
1610 or next; 2070 or next;
1611 $neigh = find $neigh, $map 2071 $neigh = find $neigh, $map
1612 or next; 2072 or next;
1613 $neigh->load; 2073 $neigh->load;
1614 2074
2075 push @neigh,
1615 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2076 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1616 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2077 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1617 } 2078 }
1618 2079
1619 for (@diag) { 2080 for (grep defined $_->[0], @neigh) {
2081 my ($path, $origin) = @$_;
1620 my $neigh = find @$_ 2082 my $neigh = find $path, $origin
1621 or next; 2083 or next;
1622 $neigh->load; 2084 $neigh->load;
1623 } 2085 }
1624} 2086}
1625 2087
… …
1630} 2092}
1631 2093
1632sub do_load_sync { 2094sub do_load_sync {
1633 my ($map) = @_; 2095 my ($map) = @_;
1634 2096
2097 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2098 if $Coro::current == $Coro::main;
2099
1635 cf::sync_job { $map->load }; 2100 cf::sync_job { $map->load };
1636} 2101}
1637 2102
1638our %MAP_PREFETCH; 2103our %MAP_PREFETCH;
1639our $MAP_PREFETCHER = undef; 2104our $MAP_PREFETCHER = undef;
1640 2105
1641sub find_async { 2106sub find_async {
1642 my ($path, $origin) = @_; 2107 my ($path, $origin, $load) = @_;
1643 2108
1644 $path = normalise $path, $origin && $origin->{path}; 2109 $path = normalise $path, $origin && $origin->{path};
1645 2110
1646 if (my $map = $cf::MAP{$path}) { 2111 if (my $map = $cf::MAP{$path}) {
1647 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2112 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1648 } 2113 }
1649 2114
1650 undef $MAP_PREFETCH{$path}; 2115 $MAP_PREFETCH{$path} |= $load;
2116
1651 $MAP_PREFETCHER ||= cf::async { 2117 $MAP_PREFETCHER ||= cf::async {
2118 $Coro::current->{desc} = "map prefetcher";
2119
1652 while (%MAP_PREFETCH) { 2120 while (%MAP_PREFETCH) {
1653 for my $path (keys %MAP_PREFETCH) { 2121 while (my ($k, $v) = each %MAP_PREFETCH) {
1654 my $map = find $path 2122 if (my $map = find $k) {
1655 or next;
1656 $map->load; 2123 $map->load if $v;
2124 }
1657 2125
1658 delete $MAP_PREFETCH{$path}; 2126 delete $MAP_PREFETCH{$k};
1659 } 2127 }
1660 } 2128 }
1661 undef $MAP_PREFETCHER; 2129 undef $MAP_PREFETCHER;
1662 }; 2130 };
1663 $MAP_PREFETCHER->prio (6); 2131 $MAP_PREFETCHER->prio (6);
… …
1666} 2134}
1667 2135
1668sub save { 2136sub save {
1669 my ($self) = @_; 2137 my ($self) = @_;
1670 2138
1671 my $lock = cf::lock_acquire "map_data:" . $self->path; 2139 my $lock = cf::lock_acquire "map_data:$self->{path}";
1672 2140
1673 $self->{last_save} = $cf::RUNTIME; 2141 $self->{last_save} = $cf::RUNTIME;
1674 2142
1675 return unless $self->dirty; 2143 return unless $self->dirty;
1676 2144
… …
1682 return if $self->{deny_save}; 2150 return if $self->{deny_save};
1683 2151
1684 local $self->{last_access} = $self->last_access;#d# 2152 local $self->{last_access} = $self->last_access;#d#
1685 2153
1686 cf::async { 2154 cf::async {
2155 $Coro::current->{desc} = "map player save";
1687 $_->contr->save for $self->players; 2156 $_->contr->save for $self->players;
1688 }; 2157 };
2158
2159 cf::get_slot 0.02;
1689 2160
1690 if ($uniq) { 2161 if ($uniq) {
1691 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2162 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1692 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2163 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1693 } else { 2164 } else {
… …
1699 my ($self) = @_; 2170 my ($self) = @_;
1700 2171
1701 # save first because save cedes 2172 # save first because save cedes
1702 $self->save; 2173 $self->save;
1703 2174
1704 my $lock = cf::lock_acquire "map_data:" . $self->path; 2175 my $lock = cf::lock_acquire "map_data:$self->{path}";
1705 2176
1706 return if $self->players; 2177 return if $self->players;
1707 return if $self->in_memory != cf::MAP_IN_MEMORY; 2178 return if $self->in_memory != cf::MAP_ACTIVE;
1708 return if $self->{deny_save}; 2179 return if $self->{deny_save};
1709 2180
2181 $self->in_memory (cf::MAP_SWAPPED);
2182
2183 $self->deactivate;
2184 $_->clear_links_to ($self) for values %cf::MAP;
1710 $self->clear; 2185 $self->clear;
1711 $self->in_memory (cf::MAP_SWAPPED);
1712} 2186}
1713 2187
1714sub reset_at { 2188sub reset_at {
1715 my ($self) = @_; 2189 my ($self) = @_;
1716 2190
… …
1748 if $uniq; 2222 if $uniq;
1749 } 2223 }
1750 2224
1751 delete $cf::MAP{$self->path}; 2225 delete $cf::MAP{$self->path};
1752 2226
2227 $self->deactivate;
2228 $_->clear_links_to ($self) for values %cf::MAP;
1753 $self->clear; 2229 $self->clear;
1754
1755 $_->clear_links_to ($self) for values %cf::MAP;
1756 2230
1757 $self->unlink_save; 2231 $self->unlink_save;
1758 $self->destroy; 2232 $self->destroy;
1759} 2233}
1760 2234
1761my $nuke_counter = "aaaa"; 2235my $nuke_counter = "aaaa";
1762 2236
1763sub nuke { 2237sub nuke {
1764 my ($self) = @_; 2238 my ($self) = @_;
1765 2239
2240 {
2241 my $lock = cf::lock_acquire "map_data:$self->{path}";
2242
1766 delete $cf::MAP{$self->path}; 2243 delete $cf::MAP{$self->path};
1767 2244
1768 $self->unlink_save; 2245 $self->unlink_save;
1769 2246
1770 bless $self, "cf::map"; 2247 bless $self, "cf::map";
1771 delete $self->{deny_reset}; 2248 delete $self->{deny_reset};
1772 $self->{deny_save} = 1; 2249 $self->{deny_save} = 1;
1773 $self->reset_timeout (1); 2250 $self->reset_timeout (1);
1774 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2251 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1775 2252
1776 $cf::MAP{$self->path} = $self; 2253 $cf::MAP{$self->path} = $self;
2254 }
1777 2255
1778 $self->reset; # polite request, might not happen 2256 $self->reset; # polite request, might not happen
2257}
2258
2259=item $maps = cf::map::tmp_maps
2260
2261Returns an arrayref with all map paths of currently instantiated and saved
2262maps. May block.
2263
2264=cut
2265
2266sub tmp_maps() {
2267 [
2268 map {
2269 utf8::decode $_;
2270 /\.map$/
2271 ? normalise $_
2272 : ()
2273 } @{ aio_readdir $TMPDIR or [] }
2274 ]
2275}
2276
2277=item $maps = cf::map::random_maps
2278
2279Returns an arrayref with all map paths of currently instantiated and saved
2280random maps. May block.
2281
2282=cut
2283
2284sub random_maps() {
2285 [
2286 map {
2287 utf8::decode $_;
2288 /\.map$/
2289 ? normalise "?random/$_"
2290 : ()
2291 } @{ aio_readdir $RANDOMDIR or [] }
2292 ]
1779} 2293}
1780 2294
1781=item cf::map::unique_maps 2295=item cf::map::unique_maps
1782 2296
1783Returns an arrayref of paths of all shared maps that have 2297Returns an arrayref of paths of all shared maps that have
1784instantiated unique items. May block. 2298instantiated unique items. May block.
1785 2299
1786=cut 2300=cut
1787 2301
1788sub unique_maps() { 2302sub unique_maps() {
1789 my $files = aio_readdir $UNIQUEDIR 2303 [
1790 or return; 2304 map {
1791
1792 my @paths;
1793
1794 for (@$files) {
1795 utf8::decode $_; 2305 utf8::decode $_;
1796 next if /\.pst$/; 2306 s/\.map$//; # TODO future compatibility hack
1797 next unless /^$PATH_SEP/o; 2307 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1798 2308 ? ()
1799 push @paths, cf::map::normalise $_; 2309 : normalise $_
2310 } @{ aio_readdir $UNIQUEDIR or [] }
1800 } 2311 ]
1801
1802 \@paths
1803} 2312}
1804
1805package cf;
1806 2313
1807=back 2314=back
1808 2315
1809=head3 cf::object 2316=head3 cf::object
1810 2317
… …
1814 2321
1815=over 4 2322=over 4
1816 2323
1817=item $ob->inv_recursive 2324=item $ob->inv_recursive
1818 2325
1819Returns 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.
1820 2328
1821=cut 2329=cut
1822 2330
1823sub inv_recursive_; 2331sub inv_recursive_;
1824sub inv_recursive_ { 2332sub inv_recursive_ {
… …
1827 2335
1828sub inv_recursive { 2336sub inv_recursive {
1829 inv_recursive_ inv $_[0] 2337 inv_recursive_ inv $_[0]
1830} 2338}
1831 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
1832package cf; 2368package cf;
1833 2369
1834=back 2370=back
1835 2371
1836=head3 cf::object::player 2372=head3 cf::object::player
… …
1842Sends 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>
1843can 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
1844dialogue with the given NPC character. 2380dialogue with the given NPC character.
1845 2381
1846=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};
1847 2397
1848# rough implementation of a future "reply" method that works 2398# rough implementation of a future "reply" method that works
1849# with dialog boxes. 2399# with dialog boxes.
1850#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
1851sub cf::object::player::reply($$$;$) { 2401sub cf::object::player::reply($$$;$) {
… …
1853 2403
1854 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2404 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1855 2405
1856 if ($self->{record_replies}) { 2406 if ($self->{record_replies}) {
1857 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2407 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2408
1858 } 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 {
1859 $msg = $npc->name . " says: $msg" if $npc; 2417 $msg = $npc->name . " says: $msg" if $npc;
1860 $self->message ($msg, $flags); 2418 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2419 }
1861 } 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 (@_);
1862} 2431}
1863 2432
1864=item $player_object->may ("access") 2433=item $player_object->may ("access")
1865 2434
1866Returns wether the given player is authorized to access resource "access" 2435Returns wether the given player is authorized to access resource "access"
… …
1945 # use -1 or undef as default coordinates, not 0, 0 2514 # use -1 or undef as default coordinates, not 0, 0
1946 ($x, $y) = ($map->enter_x, $map->enter_y) 2515 ($x, $y) = ($map->enter_x, $map->enter_y)
1947 if $x <=0 && $y <= 0; 2516 if $x <=0 && $y <= 0;
1948 2517
1949 $map->load; 2518 $map->load;
1950 $map->load_diag; 2519 $map->load_neighbours;
1951 2520
1952 return unless $self->contr->active; 2521 return unless $self->contr->active;
1953 $self->activate_recursive; 2522 $self->activate_recursive;
1954 2523
1955 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2524 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1956 $self->enter_map ($map, $x, $y); 2525 $self->enter_map ($map, $x, $y);
1957} 2526}
1958 2527
1959=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2528=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1960 2529
1961Moves the player to the given map-path and coordinates by first freezing 2530Moves the player to the given map-path and coordinates by first freezing
1962her, loading and preparing them map, calling the provided $check callback 2531her, loading and preparing them map, calling the provided $check callback
1963that has to return the map if sucecssful, and then unfreezes the player on 2532that has to return the map if sucecssful, and then unfreezes the player on
1964the new (success) or old (failed) map position. 2533the new (success) or old (failed) map position. In either case, $done will
2534be called at the end of this process.
2535
2536Note that $check will be called with a potentially non-loaded map, so if
2537it needs a loaded map it has to call C<< ->load >>.
1965 2538
1966=cut 2539=cut
1967 2540
1968our $GOTOGEN; 2541our $GOTOGEN;
1969 2542
1970sub cf::object::player::goto { 2543sub cf::object::player::goto {
1971 my ($self, $path, $x, $y, $check) = @_; 2544 my ($self, $path, $x, $y, $check, $done) = @_;
1972 2545
1973 # do generation counting so two concurrent goto's will be executed in-order 2546 # do generation counting so two concurrent goto's will be executed in-order
1974 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2547 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1975 2548
1976 $self->enter_link; 2549 $self->enter_link;
1977 2550
1978 (async { 2551 (async {
2552 $Coro::current->{desc} = "player::goto $path $x $y";
2553
2554 # *tag paths override both path and x|y
2555 if ($path =~ /^\*(.*)$/) {
2556 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2557 my $ob = $obs[rand @obs];
2558
2559 # see if we actually can go there
2560 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2561 $ob = $obs[rand @obs];
2562 } else {
2563 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2564 }
2565 # else put us there anyways for now #d#
2566
2567 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2568 } else {
2569 ($path, $x, $y) = (undef, undef, undef);
2570 }
2571 }
2572
1979 my $map = eval { 2573 my $map = eval {
1980 my $map = cf::map::find $path; 2574 my $map = defined $path ? cf::map::find $path : undef;
1981 2575
1982 if ($map) { 2576 if ($map) {
1983 $map = $map->customise_for ($self); 2577 $map = $map->customise_for ($self);
1984 $map = $check->($map) if $check && $map; 2578 $map = $check->($map) if $check && $map;
1985 } else { 2579 } else {
1986 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2580 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
1987 } 2581 }
1988 2582
1989 $map 2583 $map
1990 }; 2584 };
1991 2585
… …
1996 2590
1997 if ($gen == $self->{_goto_generation}) { 2591 if ($gen == $self->{_goto_generation}) {
1998 delete $self->{_goto_generation}; 2592 delete $self->{_goto_generation};
1999 $self->leave_link ($map, $x, $y); 2593 $self->leave_link ($map, $x, $y);
2000 } 2594 }
2595
2596 $done->() if $done;
2001 })->prio (1); 2597 })->prio (1);
2002} 2598}
2003 2599
2004=item $player_object->enter_exit ($exit_object) 2600=item $player_object->enter_exit ($exit_object)
2005 2601
… …
2025} 2621}
2026 2622
2027sub prepare_random_map { 2623sub prepare_random_map {
2028 my ($exit) = @_; 2624 my ($exit) = @_;
2029 2625
2030 my $guard = cf::lock_acquire "exit_prepare:$exit";
2031
2032 # all this does is basically replace the /! path by 2626 # all this does is basically replace the /! path by
2033 # a new random map path (?random/...) with a seed 2627 # a new random map path (?random/...) with a seed
2034 # that depends on the exit object 2628 # that depends on the exit object
2035 2629
2036 my $rmp = parse_random_map_params $exit->msg; 2630 my $rmp = parse_random_map_params $exit->msg;
… …
2038 if ($exit->map) { 2632 if ($exit->map) {
2039 $rmp->{region} = $exit->region->name; 2633 $rmp->{region} = $exit->region->name;
2040 $rmp->{origin_map} = $exit->map->path; 2634 $rmp->{origin_map} = $exit->map->path;
2041 $rmp->{origin_x} = $exit->x; 2635 $rmp->{origin_x} = $exit->x;
2042 $rmp->{origin_y} = $exit->y; 2636 $rmp->{origin_y} = $exit->y;
2637
2638 $exit->map->touch;
2043 } 2639 }
2044 2640
2045 $rmp->{random_seed} ||= $exit->random_seed; 2641 $rmp->{random_seed} ||= $exit->random_seed;
2046 2642
2047 my $data = cf::to_json $rmp; 2643 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2048 my $md5 = Digest::MD5::md5_hex $data; 2644 my $md5 = Digest::MD5::md5_hex $data;
2049 my $meta = "$RANDOMDIR/$md5.meta"; 2645 my $meta = "$RANDOMDIR/$md5.meta";
2050 2646
2051 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2647 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2052 aio_write $fh, 0, (length $data), $data, 0; 2648 aio_write $fh, 0, (length $data), $data, 0;
2053 undef $fh; 2649 undef $fh;
2054 aio_rename "$meta~", $meta; 2650 aio_rename "$meta~", $meta;
2055 2651
2652 my $slaying = "?random/$md5";
2653
2654 if ($exit->valid) {
2056 $exit->slaying ("?random/$md5"); 2655 $exit->slaying ("?random/$md5");
2057 $exit->msg (undef); 2656 $exit->msg (undef);
2657 }
2058 } 2658 }
2059} 2659}
2060 2660
2061sub cf::object::player::enter_exit { 2661sub cf::object::player::enter_exit {
2062 my ($self, $exit) = @_; 2662 my ($self, $exit) = @_;
2063 2663
2064 return unless $self->type == cf::PLAYER; 2664 return unless $self->type == cf::PLAYER;
2065 2665
2066 if ($exit->slaying eq "/!") {
2067 #TODO: this should de-fi-ni-te-ly not be a sync-job
2068 # the problem is that $exit might not survive long enough
2069 # so it needs to be done right now, right here
2070 cf::sync_job { prepare_random_map $exit };
2071 }
2072
2073 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2074 my $hp = $exit->stats->hp;
2075 my $sp = $exit->stats->sp;
2076
2077 $self->enter_link; 2666 $self->enter_link;
2078 2667
2079 (async { 2668 (async {
2080 $self->deactivate_recursive; # just to be sure 2669 $Coro::current->{desc} = "enter_exit";
2670
2081 unless (eval { 2671 unless (eval {
2672 $self->deactivate_recursive; # just to be sure
2673
2674 # random map handling
2675 {
2676 my $guard = cf::lock_acquire "exit_prepare:$exit";
2677
2678 prepare_random_map $exit
2679 if $exit->slaying eq "/!";
2680 }
2681
2682 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2683 my $x = $exit->stats->hp;
2684 my $y = $exit->stats->sp;
2685
2082 $self->goto ($slaying, $hp, $sp); 2686 $self->goto ($map, $x, $y);
2083 2687
2688 # if exit is damned, update players death & WoR home-position
2689 $self->contr->savebed ($map, $x, $y)
2690 if $exit->flag (cf::FLAG_DAMNED);
2691
2084 1; 2692 1
2085 }) { 2693 }) {
2086 $self->message ("Something went wrong deep within the crossfire server. " 2694 $self->message ("Something went wrong deep within the crossfire server. "
2087 . "I'll try to bring you back to the map you were before. " 2695 . "I'll try to bring you back to the map you were before. "
2088 . "Please report this to the dungeon master!", 2696 . "Please report this to the dungeon master!",
2089 cf::NDI_UNIQUE | cf::NDI_RED); 2697 cf::NDI_UNIQUE | cf::NDI_RED);
… …
2110 2718
2111 utf8::encode $text; 2719 utf8::encode $text;
2112 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2720 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2113} 2721}
2114 2722
2723=item $client->send_msg ($channel, $msg, $color, [extra...])
2724
2725Send a drawinfo or msg packet to the client, formatting the msg for the
2726client if neccessary. C<$type> should be a string identifying the type of
2727the message, with C<log> being the default. If C<$color> is negative, suppress
2728the message unless the client supports the msg packet.
2729
2730=cut
2731
2732# non-persistent channels (usually the info channel)
2733our %CHANNEL = (
2734 "c/identify" => {
2735 id => "infobox",
2736 title => "Identify",
2737 reply => undef,
2738 tooltip => "Items recently identified",
2739 },
2740 "c/examine" => {
2741 id => "infobox",
2742 title => "Examine",
2743 reply => undef,
2744 tooltip => "Signs and other items you examined",
2745 },
2746 "c/book" => {
2747 id => "infobox",
2748 title => "Book",
2749 reply => undef,
2750 tooltip => "The contents of a note or book",
2751 },
2752 "c/lookat" => {
2753 id => "infobox",
2754 title => "Look",
2755 reply => undef,
2756 tooltip => "What you saw there",
2757 },
2758 "c/who" => {
2759 id => "infobox",
2760 title => "Players",
2761 reply => undef,
2762 tooltip => "Shows players who are currently online",
2763 },
2764 "c/body" => {
2765 id => "infobox",
2766 title => "Body Parts",
2767 reply => undef,
2768 tooltip => "Shows which body parts you posess and are available",
2769 },
2770 "c/uptime" => {
2771 id => "infobox",
2772 title => "Uptime",
2773 reply => undef,
2774 tooltip => "How long the server has been running since last restart",
2775 },
2776 "c/mapinfo" => {
2777 id => "infobox",
2778 title => "Map Info",
2779 reply => undef,
2780 tooltip => "Information related to the maps",
2781 },
2782 "c/party" => {
2783 id => "party",
2784 title => "Party",
2785 reply => "gsay ",
2786 tooltip => "Messages and chat related to your party",
2787 },
2788);
2789
2790sub cf::client::send_msg {
2791 my ($self, $channel, $msg, $color, @extra) = @_;
2792
2793 $msg = $self->pl->expand_cfpod ($msg);
2794
2795 $color &= cf::NDI_CLIENT_MASK; # just in case...
2796
2797 # check predefined channels, for the benefit of C
2798 if ($CHANNEL{$channel}) {
2799 $channel = $CHANNEL{$channel};
2800
2801 $self->ext_msg (channel_info => $channel)
2802 if $self->can_msg;
2803
2804 $channel = $channel->{id};
2805
2806 } elsif (ref $channel) {
2807 # send meta info to client, if not yet sent
2808 unless (exists $self->{channel}{$channel->{id}}) {
2809 $self->{channel}{$channel->{id}} = $channel;
2810 $self->ext_msg (channel_info => $channel)
2811 if $self->can_msg;
2812 }
2813
2814 $channel = $channel->{id};
2815 }
2816
2817 return unless @extra || length $msg;
2818
2819 if ($self->can_msg) {
2820 # default colour, mask it out
2821 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2822 if $color & cf::NDI_DEF;
2823
2824 my $pkt = "msg "
2825 . $self->{json_coder}->encode (
2826 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2827 );
2828
2829 # try lzf for large packets
2830 $pkt = "lzf " . Compress::LZF::compress $pkt
2831 if 1024 <= length $pkt and $self->{can_lzf};
2832
2833 # split very large packets
2834 if (8192 < length $pkt and $self->{can_lzf}) {
2835 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2836 $pkt = "frag";
2837 }
2838
2839 $self->send_packet ($pkt);
2840 } else {
2841 if ($color >= 0) {
2842 # replace some tags by gcfclient-compatible ones
2843 for ($msg) {
2844 1 while
2845 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2846 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2847 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2848 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2849 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2850 }
2851
2852 $color &= cf::NDI_COLOR_MASK;
2853
2854 utf8::encode $msg;
2855
2856 if (0 && $msg =~ /\[/) {
2857 # COMMAND/INFO
2858 $self->send_packet ("drawextinfo $color 10 8 $msg")
2859 } else {
2860 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2861 $self->send_packet ("drawinfo $color $msg")
2862 }
2863 }
2864 }
2865}
2866
2115=item $client->ext_event ($type, %msg) 2867=item $client->ext_msg ($type, @msg)
2116 2868
2117Sends an exti event to the client. 2869Sends an ext event to the client.
2118 2870
2119=cut 2871=cut
2120 2872
2121sub cf::client::ext_event($$%) { 2873sub cf::client::ext_msg($$@) {
2122 my ($self, $type, %msg) = @_; 2874 my ($self, $type, @msg) = @_;
2123 2875
2876 if ($self->extcmd == 2) {
2877 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2878 } elsif ($self->extcmd == 1) { # TODO: remove
2124 $msg{msgtype} = "event_$type"; 2879 push @msg, msgtype => "event_$type";
2125 $self->send_packet ("ext " . cf::to_json \%msg); 2880 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2881 }
2882}
2883
2884=item $client->ext_reply ($msgid, @msg)
2885
2886Sends an ext reply to the client.
2887
2888=cut
2889
2890sub cf::client::ext_reply($$@) {
2891 my ($self, $id, @msg) = @_;
2892
2893 if ($self->extcmd == 2) {
2894 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2895 } elsif ($self->extcmd == 1) {
2896 #TODO: version 1, remove
2897 unshift @msg, msgtype => "reply", msgid => $id;
2898 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2899 }
2126} 2900}
2127 2901
2128=item $success = $client->query ($flags, "text", \&cb) 2902=item $success = $client->query ($flags, "text", \&cb)
2129 2903
2130Queues a query to the client, calling the given callback with 2904Queues a query to the client, calling the given callback with
2131the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2905the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2132C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2906C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2133 2907
2134Queries can fail, so check the return code. Or don't, as queries will become 2908Queries can fail, so check the return code. Or don't, as queries will
2135reliable at some point in the future. 2909become reliable at some point in the future.
2136 2910
2137=cut 2911=cut
2138 2912
2139sub cf::client::query { 2913sub cf::client::query {
2140 my ($self, $flags, $text, $cb) = @_; 2914 my ($self, $flags, $text, $cb) = @_;
… …
2148 utf8::encode $text; 2922 utf8::encode $text;
2149 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2923 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2150 2924
2151 $self->send_packet ($self->{query_queue}[0][0]) 2925 $self->send_packet ($self->{query_queue}[0][0])
2152 if @{ $self->{query_queue} } == 1; 2926 if @{ $self->{query_queue} } == 1;
2927
2928 1
2153} 2929}
2154 2930
2155cf::client->attach ( 2931cf::client->attach (
2932 on_connect => sub {
2933 my ($ns) = @_;
2934
2935 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2936 },
2156 on_reply => sub { 2937 on_reply => sub {
2157 my ($ns, $msg) = @_; 2938 my ($ns, $msg) = @_;
2158 2939
2159 # this weird shuffling is so that direct followup queries 2940 # this weird shuffling is so that direct followup queries
2160 # get handled first 2941 # get handled first
… …
2172 } else { 2953 } else {
2173 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2954 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2174 } 2955 }
2175 } 2956 }
2176 }, 2957 },
2958 on_exticmd => sub {
2959 my ($ns, $buf) = @_;
2960
2961 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2962
2963 if (ref $msg) {
2964 my ($type, $reply, @payload) =
2965 "ARRAY" eq ref $msg
2966 ? @$msg
2967 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2968
2969 my @reply;
2970
2971 if (my $cb = $EXTICMD{$type}) {
2972 @reply = $cb->($ns, @payload);
2973 }
2974
2975 $ns->ext_reply ($reply, @reply)
2976 if $reply;
2977
2978 } else {
2979 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2980 }
2981
2982 cf::override;
2983 },
2177); 2984);
2178 2985
2179=item $client->async (\&cb) 2986=item $client->async (\&cb)
2180 2987
2181Create a new coroutine, running the specified callback. The coroutine will 2988Create a new coroutine, running the specified callback. The coroutine will
… …
2222our $safe = new Safe "safe"; 3029our $safe = new Safe "safe";
2223our $safe_hole = new Safe::Hole; 3030our $safe_hole = new Safe::Hole;
2224 3031
2225$SIG{FPE} = 'IGNORE'; 3032$SIG{FPE} = 'IGNORE';
2226 3033
2227$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3034$safe->permit_only (Opcode::opset qw(
3035 :base_core :base_mem :base_orig :base_math
3036 grepstart grepwhile mapstart mapwhile
3037 sort time
3038));
2228 3039
2229# here we export the classes and methods available to script code 3040# here we export the classes and methods available to script code
2230 3041
2231=pod 3042=pod
2232 3043
2233The following functions and methods are available within a safe environment: 3044The following functions and methods are available within a safe environment:
2234 3045
2235 cf::object contr pay_amount pay_player map 3046 cf::object
3047 contr pay_amount pay_player map x y force_find force_add destroy
3048 insert remove name archname title slaying race decrease split
3049
2236 cf::object::player player 3050 cf::object::player
2237 cf::player peaceful 3051 player
2238 cf::map trigger 3052
3053 cf::player
3054 peaceful
3055
3056 cf::map
3057 trigger
2239 3058
2240=cut 3059=cut
2241 3060
2242for ( 3061for (
2243 ["cf::object" => qw(contr pay_amount pay_player map)], 3062 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3063 insert remove inv nrof name archname title slaying race
3064 decrease split destroy change_exp)],
2244 ["cf::object::player" => qw(player)], 3065 ["cf::object::player" => qw(player)],
2245 ["cf::player" => qw(peaceful)], 3066 ["cf::player" => qw(peaceful)],
2246 ["cf::map" => qw(trigger)], 3067 ["cf::map" => qw(trigger)],
2247) { 3068) {
2248 no strict 'refs'; 3069 no strict 'refs';
… …
2319=back 3140=back
2320 3141
2321=cut 3142=cut
2322 3143
2323############################################################################# 3144#############################################################################
2324
2325=head2 EXTENSION DATABASE SUPPORT
2326
2327Crossfire maintains a very simple database for extension use. It can
2328currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2329convert to/from binary).
2330
2331The parameter C<$family> should best start with the name of the extension
2332using it, it should be unique.
2333
2334=over 4
2335
2336=item $value = cf::db_get $family => $key
2337
2338Returns a single value from the database.
2339
2340=item cf::db_put $family => $key => $value
2341
2342Stores the given C<$value> in the family.
2343
2344=cut
2345
2346our $DB;
2347
2348sub db_init {
2349 unless ($DB) {
2350 $DB = BDB::db_create $DB_ENV;
2351
2352 cf::sync_job {
2353 eval {
2354 $DB->set_flags (BDB::CHKSUM);
2355
2356 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2357 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2358 cf::cleanup "db_open(db): $!" if $!;
2359 };
2360 cf::cleanup "db_open(db): $@" if $@;
2361 };
2362 }
2363}
2364
2365sub db_get($$) {
2366 my $key = "$_[0]/$_[1]";
2367
2368 cf::sync_job {
2369 BDB::db_get $DB, undef, $key, my $data;
2370
2371 $! ? ()
2372 : $data
2373 }
2374}
2375
2376sub db_put($$$) {
2377 BDB::dbreq_pri 4;
2378 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2379}
2380
2381=item cf::cache $id => [$paths...], $processversion => $process
2382
2383Generic caching function that returns the value of the resource $id,
2384caching and regenerating as required.
2385
2386This function can block.
2387
2388=cut
2389
2390sub cache {
2391 my ($id, $src, $processversion, $process) = @_;
2392
2393 my $meta =
2394 join "\x00",
2395 $processversion,
2396 map {
2397 aio_stat $_
2398 and Carp::croak "$_: $!";
2399
2400 ($_, (stat _)[7,9])
2401 } @$src;
2402
2403 my $dbmeta = db_get cache => "$id/meta";
2404 if ($dbmeta ne $meta) {
2405 # changed, we may need to process
2406
2407 my @data;
2408 my $md5;
2409
2410 for (0 .. $#$src) {
2411 0 <= aio_load $src->[$_], $data[$_]
2412 or Carp::croak "$src->[$_]: $!";
2413 }
2414
2415 # if processing is expensive, check
2416 # checksum first
2417 if (1) {
2418 $md5 =
2419 join "\x00",
2420 $processversion,
2421 map {
2422 Coro::cede;
2423 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2424 } 0.. $#$src;
2425
2426
2427 my $dbmd5 = db_get cache => "$id/md5";
2428 if ($dbmd5 eq $md5) {
2429 db_put cache => "$id/meta", $meta;
2430
2431 return db_get cache => "$id/data";
2432 }
2433 }
2434
2435 my $t1 = Time::HiRes::time;
2436 my $data = $process->(\@data);
2437 my $t2 = Time::HiRes::time;
2438
2439 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2440
2441 db_put cache => "$id/data", $data;
2442 db_put cache => "$id/md5" , $md5;
2443 db_put cache => "$id/meta", $meta;
2444
2445 return $data;
2446 }
2447
2448 db_get cache => "$id/data"
2449}
2450
2451=item fork_call { }, $args
2452
2453Executes the given code block with the given arguments in a seperate
2454process, returning the results. Everything must be serialisable with
2455Coro::Storable. May, of course, block. Note that the executed sub may
2456never block itself or use any form of Event handling.
2457
2458=cut
2459
2460sub fork_call(&@) {
2461 my ($cb, @args) = @_;
2462
2463# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2464# or die "socketpair: $!";
2465 pipe my $fh1, my $fh2
2466 or die "pipe: $!";
2467
2468 if (my $pid = fork) {
2469 close $fh2;
2470
2471 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2472 $res = Coro::Storable::thaw $res;
2473
2474 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2475
2476 die $$res unless "ARRAY" eq ref $res;
2477
2478 return wantarray ? @$res : $res->[-1];
2479 } else {
2480 reset_signals;
2481 local $SIG{__WARN__};
2482 local $SIG{__DIE__};
2483 eval {
2484 close $fh1;
2485
2486 my @res = eval { $cb->(@args) };
2487 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2488 };
2489
2490 warn $@ if $@;
2491 _exit 0;
2492 }
2493}
2494
2495#############################################################################
2496# the server's init and main functions 3145# the server's init and main functions
2497 3146
2498sub load_facedata($) { 3147sub load_facedata($) {
2499 my ($path) = @_; 3148 my ($path) = @_;
3149
3150 # HACK to clear player env face cache, we need some signal framework
3151 # for this (global event?)
3152 %ext::player_env::MUSIC_FACE_CACHE = ();
3153
3154 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2500 3155
2501 warn "loading facedata from $path\n"; 3156 warn "loading facedata from $path\n";
2502 3157
2503 my $facedata; 3158 my $facedata;
2504 0 < aio_load $path, $facedata 3159 0 < aio_load $path, $facedata
… …
2507 $facedata = Coro::Storable::thaw $facedata; 3162 $facedata = Coro::Storable::thaw $facedata;
2508 3163
2509 $facedata->{version} == 2 3164 $facedata->{version} == 2
2510 or cf::cleanup "$path: version mismatch, cannot proceed."; 3165 or cf::cleanup "$path: version mismatch, cannot proceed.";
2511 3166
3167 # patch in the exptable
3168 $facedata->{resource}{"res/exp_table"} = {
3169 type => FT_RSRC,
3170 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3171 };
3172 cf::cede_to_tick;
3173
2512 { 3174 {
2513 my $faces = $facedata->{faceinfo}; 3175 my $faces = $facedata->{faceinfo};
2514 3176
2515 while (my ($face, $info) = each %$faces) { 3177 while (my ($face, $info) = each %$faces) {
2516 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3178 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3179
2517 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3180 cf::face::set_visibility $idx, $info->{visibility};
3181 cf::face::set_magicmap $idx, $info->{magicmap};
2518 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3182 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2519 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3183 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2520 Coro::cede; 3184
3185 cf::cede_to_tick;
2521 } 3186 }
2522 3187
2523 while (my ($face, $info) = each %$faces) { 3188 while (my ($face, $info) = each %$faces) {
2524 next unless $info->{smooth}; 3189 next unless $info->{smooth};
3190
2525 my $idx = cf::face::find $face 3191 my $idx = cf::face::find $face
2526 or next; 3192 or next;
3193
2527 if (my $smooth = cf::face::find $info->{smooth}) { 3194 if (my $smooth = cf::face::find $info->{smooth}) {
3195 cf::face::set_smooth $idx, $smooth;
2528 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3196 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2529 } else { 3197 } else {
2530 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3198 warn "smooth face '$info->{smooth}' not found for face '$face'";
2531 } 3199 }
2532 Coro::cede; 3200
3201 cf::cede_to_tick;
2533 } 3202 }
2534 } 3203 }
2535 3204
2536 { 3205 {
2537 my $anims = $facedata->{animinfo}; 3206 my $anims = $facedata->{animinfo};
2538 3207
2539 while (my ($anim, $info) = each %$anims) { 3208 while (my ($anim, $info) = each %$anims) {
2540 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3209 cf::anim::set $anim, $info->{frames}, $info->{facings};
2541 Coro::cede; 3210 cf::cede_to_tick;
2542 } 3211 }
2543 3212
2544 cf::anim::invalidate_all; # d'oh 3213 cf::anim::invalidate_all; # d'oh
2545 } 3214 }
2546 3215
3216 {
3217 # TODO: for gcfclient pleasure, we should give resources
3218 # that gcfclient doesn't grok a >10000 face index.
3219 my $res = $facedata->{resource};
3220
3221 while (my ($name, $info) = each %$res) {
3222 if (defined $info->{type}) {
3223 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3224 my $data;
3225
3226 if ($info->{type} & 1) {
3227 # prepend meta info
3228
3229 my $meta = $enc->encode ({
3230 name => $name,
3231 %{ $info->{meta} || {} },
3232 });
3233
3234 $data = pack "(w/a*)*", $meta, $info->{data};
3235 } else {
3236 $data = $info->{data};
3237 }
3238
3239 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3240 cf::face::set_type $idx, $info->{type};
3241 } else {
3242 $RESOURCE{$name} = $info;
3243 }
3244
3245 cf::cede_to_tick;
3246 }
3247 }
3248
3249 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3250
2547 1 3251 1
2548} 3252}
2549 3253
3254cf::global->attach (on_resource_update => sub {
3255 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3256 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3257
3258 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3259 my $sound = $soundconf->{compat}[$_]
3260 or next;
3261
3262 my $face = cf::face::find "sound/$sound->[1]";
3263 cf::sound::set $sound->[0] => $face;
3264 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3265 }
3266
3267 while (my ($k, $v) = each %{$soundconf->{event}}) {
3268 my $face = cf::face::find "sound/$v";
3269 cf::sound::set $k => $face;
3270 }
3271 }
3272});
3273
3274register_exticmd fx_want => sub {
3275 my ($ns, $want) = @_;
3276
3277 while (my ($k, $v) = each %$want) {
3278 $ns->fx_want ($k, $v);
3279 }
3280};
3281
3282sub load_resource_file($) {
3283 my $guard = lock_acquire "load_resource_file";
3284
3285 my $status = load_resource_file_ $_[0];
3286 get_slot 0.1, 100;
3287 cf::arch::commit_load;
3288
3289 $status
3290}
3291
2550sub reload_regions { 3292sub reload_regions {
3293 # HACK to clear player env face cache, we need some signal framework
3294 # for this (global event?)
3295 %ext::player_env::MUSIC_FACE_CACHE = ();
3296
2551 load_resource_file "$MAPDIR/regions" 3297 load_resource_file "$MAPDIR/regions"
2552 or die "unable to load regions file\n"; 3298 or die "unable to load regions file\n";
3299
3300 for (cf::region::list) {
3301 $_->{match} = qr/$_->{match}/
3302 if exists $_->{match};
3303 }
2553} 3304}
2554 3305
2555sub reload_facedata { 3306sub reload_facedata {
2556 load_facedata "$DATADIR/facedata" 3307 load_facedata "$DATADIR/facedata"
2557 or die "unable to load facedata\n"; 3308 or die "unable to load facedata\n";
… …
2568} 3319}
2569 3320
2570sub reload_resources { 3321sub reload_resources {
2571 warn "reloading resource files...\n"; 3322 warn "reloading resource files...\n";
2572 3323
3324 reload_facedata;
3325 reload_archetypes;
2573 reload_regions; 3326 reload_regions;
2574 reload_facedata;
2575 #reload_archetypes;#d#
2576 reload_archetypes;
2577 reload_treasures; 3327 reload_treasures;
2578 3328
2579 warn "finished reloading resource files\n"; 3329 warn "finished reloading resource files\n";
2580} 3330}
2581 3331
2582sub init { 3332sub init {
3333 my $guard = freeze_mainloop;
3334
3335 evthread_start IO::AIO::poll_fileno;
3336
2583 reload_resources; 3337 reload_resources;
2584} 3338}
2585 3339
2586sub cfg_load { 3340sub reload_config {
2587 open my $fh, "<:utf8", "$CONFDIR/config" 3341 open my $fh, "<:utf8", "$CONFDIR/config"
2588 or return; 3342 or return;
2589 3343
2590 local $/; 3344 local $/;
2591 *CFG = YAML::Syck::Load <$fh>; 3345 *CFG = YAML::Load <$fh>;
2592 3346
2593 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3347 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2594 3348
2595 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3349 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2596 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3350 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
2602 }; 3356 };
2603 warn $@ if $@; 3357 warn $@ if $@;
2604 } 3358 }
2605} 3359}
2606 3360
3361sub pidfile() {
3362 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3363 or die "$PIDFILE: $!";
3364 flock $fh, &Fcntl::LOCK_EX
3365 or die "$PIDFILE: flock: $!";
3366 $fh
3367}
3368
3369# make sure only one server instance is running at any one time
3370sub atomic {
3371 my $fh = pidfile;
3372
3373 my $pid = <$fh>;
3374 kill 9, $pid if $pid > 0;
3375
3376 seek $fh, 0, 0;
3377 print $fh $$;
3378}
3379
2607sub main { 3380sub main {
3381 atomic;
3382
2608 # we must not ever block the main coroutine 3383 # we must not ever block the main coroutine
2609 local $Coro::idle = sub { 3384 local $Coro::idle = sub {
2610 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3385 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2611 (async { 3386 (async {
2612 Event::one_event; 3387 $Coro::current->{desc} = "IDLE BUG HANDLER";
3388 EV::loop EV::LOOP_ONESHOT;
2613 })->prio (Coro::PRIO_MAX); 3389 })->prio (Coro::PRIO_MAX);
2614 }; 3390 };
2615 3391
2616 cfg_load; 3392 {
3393 my $guard = freeze_mainloop;
3394 reload_config;
2617 db_init; 3395 db_init;
2618 load_extensions; 3396 load_extensions;
2619 3397
2620 $TICK_WATCHER->start; 3398 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3399 }
3400
3401 utime time, time, $RUNTIMEFILE;
3402
3403 # no (long-running) fork's whatsoever before this point(!)
3404 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3405
2621 Event::loop; 3406 EV::loop;
2622} 3407}
2623 3408
2624############################################################################# 3409#############################################################################
2625# initialisation and cleanup 3410# initialisation and cleanup
2626 3411
2627# install some emergency cleanup handlers 3412# install some emergency cleanup handlers
2628BEGIN { 3413BEGIN {
3414 our %SIGWATCHER = ();
2629 for my $signal (qw(INT HUP TERM)) { 3415 for my $signal (qw(INT HUP TERM)) {
2630 Event->signal ( 3416 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2631 reentrant => 0,
2632 data => WF_AUTOCANCEL,
2633 signal => $signal,
2634 prio => 0,
2635 cb => sub {
2636 cf::cleanup "SIG$signal"; 3417 cf::cleanup "SIG$signal";
2637 },
2638 ); 3418 };
3419 }
3420}
3421
3422sub write_runtime_sync {
3423 # first touch the runtime file to show we are still running:
3424 # the fsync below can take a very very long time.
3425
3426 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3427
3428 my $guard = cf::lock_acquire "write_runtime";
3429
3430 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
3431 or return;
3432
3433 my $value = $cf::RUNTIME + 90 + 10;
3434 # 10 is the runtime save interval, for a monotonic clock
3435 # 60 allows for the watchdog to kill the server.
3436
3437 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3438 and return;
3439
3440 # always fsync - this file is important
3441 aio_fsync $fh
3442 and return;
3443
3444 # touch it again to show we are up-to-date
3445 aio_utime $fh, undef, undef;
3446
3447 close $fh
3448 or return;
3449
3450 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3451 and return;
3452
3453 warn "runtime file written.\n";
3454
2639 } 3455 1
3456}
3457
3458our $uuid_lock;
3459our $uuid_skip;
3460
3461sub write_uuid_sync($) {
3462 $uuid_skip ||= $_[0];
3463
3464 return if $uuid_lock;
3465 local $uuid_lock = 1;
3466
3467 my $uuid = "$LOCALDIR/uuid";
3468
3469 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3470 or return;
3471
3472 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3473 $uuid_skip = 0;
3474
3475 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3476 and return;
3477
3478 # always fsync - this file is important
3479 aio_fsync $fh
3480 and return;
3481
3482 close $fh
3483 or return;
3484
3485 aio_rename "$uuid~", $uuid
3486 and return;
3487
3488 warn "uuid file written ($value).\n";
3489
3490 1
3491
3492}
3493
3494sub write_uuid($$) {
3495 my ($skip, $sync) = @_;
3496
3497 $sync ? write_uuid_sync $skip
3498 : async { write_uuid_sync $skip };
2640} 3499}
2641 3500
2642sub emergency_save() { 3501sub emergency_save() {
2643 my $freeze_guard = cf::freeze_mainloop; 3502 my $freeze_guard = cf::freeze_mainloop;
2644 3503
… …
2650 # and maps saved/destroyed asynchronously. 3509 # and maps saved/destroyed asynchronously.
2651 warn "begin emergency player save\n"; 3510 warn "begin emergency player save\n";
2652 for my $login (keys %cf::PLAYER) { 3511 for my $login (keys %cf::PLAYER) {
2653 my $pl = $cf::PLAYER{$login} or next; 3512 my $pl = $cf::PLAYER{$login} or next;
2654 $pl->valid or next; 3513 $pl->valid or next;
3514 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2655 $pl->save; 3515 $pl->save;
2656 } 3516 }
2657 warn "end emergency player save\n"; 3517 warn "end emergency player save\n";
2658 3518
2659 warn "begin emergency map save\n"; 3519 warn "begin emergency map save\n";
… …
2665 warn "end emergency map save\n"; 3525 warn "end emergency map save\n";
2666 3526
2667 warn "begin emergency database checkpoint\n"; 3527 warn "begin emergency database checkpoint\n";
2668 BDB::db_env_txn_checkpoint $DB_ENV; 3528 BDB::db_env_txn_checkpoint $DB_ENV;
2669 warn "end emergency database checkpoint\n"; 3529 warn "end emergency database checkpoint\n";
3530
3531 warn "begin write uuid\n";
3532 write_uuid_sync 1;
3533 warn "end write uuid\n";
2670 }; 3534 };
2671 3535
2672 warn "leave emergency perl save\n"; 3536 warn "leave emergency perl save\n";
2673} 3537}
2674 3538
2675sub post_cleanup { 3539sub post_cleanup {
2676 my ($make_core) = @_; 3540 my ($make_core) = @_;
2677 3541
2678 warn Carp::longmess "post_cleanup backtrace" 3542 warn Carp::longmess "post_cleanup backtrace"
2679 if $make_core; 3543 if $make_core;
3544
3545 my $fh = pidfile;
3546 unlink $PIDFILE if <$fh> == $$;
2680} 3547}
3548
3549# a safer delete_package, copied from Symbol
3550sub clear_package($) {
3551 my $pkg = shift;
3552
3553 # expand to full symbol table name if needed
3554 unless ($pkg =~ /^main::.*::$/) {
3555 $pkg = "main$pkg" if $pkg =~ /^::/;
3556 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3557 $pkg .= '::' unless $pkg =~ /::$/;
3558 }
3559
3560 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3561 my $stem_symtab = *{$stem}{HASH};
3562
3563 defined $stem_symtab and exists $stem_symtab->{$leaf}
3564 or return;
3565
3566 # clear all symbols
3567 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3568 for my $name (keys %$leaf_symtab) {
3569 _gv_clear *{"$pkg$name"};
3570# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3571 }
3572 warn "cleared package #$pkg\n";#d#
3573}
3574
3575our $RELOAD; # how many times to reload
2681 3576
2682sub do_reload_perl() { 3577sub do_reload_perl() {
2683 # can/must only be called in main 3578 # can/must only be called in main
2684 if ($Coro::current != $Coro::main) { 3579 if ($Coro::current != $Coro::main) {
2685 warn "can only reload from main coroutine"; 3580 warn "can only reload from main coroutine";
2686 return; 3581 return;
2687 } 3582 }
2688 3583
3584 return if $RELOAD++;
3585
3586 while ($RELOAD) {
2689 warn "reloading..."; 3587 warn "reloading...";
2690 3588
2691 warn "entering sync_job"; 3589 warn "entering sync_job";
2692 3590
2693 cf::sync_job { 3591 cf::sync_job {
2694 cf::write_runtime; # external watchdog should not bark 3592 cf::write_runtime_sync; # external watchdog should not bark
2695 cf::emergency_save; 3593 cf::emergency_save;
2696 cf::write_runtime; # external watchdog should not bark 3594 cf::write_runtime_sync; # external watchdog should not bark
2697 3595
2698 warn "syncing database to disk"; 3596 warn "syncing database to disk";
2699 BDB::db_env_txn_checkpoint $DB_ENV; 3597 BDB::db_env_txn_checkpoint $DB_ENV;
2700 3598
2701 # if anything goes wrong in here, we should simply crash as we already saved 3599 # if anything goes wrong in here, we should simply crash as we already saved
2702 3600
2703 warn "cancelling all WF_AUTOCANCEL watchers";
2704 for (Event::all_watchers) {
2705 $_->cancel if $_->data & WF_AUTOCANCEL;
2706 }
2707
2708 warn "flushing outstanding aio requests"; 3601 warn "flushing outstanding aio requests";
2709 for (;;) {
2710 BDB::flush;
2711 IO::AIO::flush;
2712 Coro::cede;
2713 last unless IO::AIO::nreqs || BDB::nreqs; 3602 while (IO::AIO::nreqs || BDB::nreqs) {
2714 warn "iterate..."; 3603 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2715 }
2716
2717 ++$RELOAD;
2718
2719 warn "cancelling all extension coros";
2720 $_->cancel for values %EXT_CORO;
2721 %EXT_CORO = ();
2722
2723 warn "removing commands";
2724 %COMMAND = ();
2725
2726 warn "removing ext commands";
2727 %EXTCMD = ();
2728
2729 warn "unloading/nuking all extensions";
2730 for my $pkg (@EXTS) {
2731 warn "... unloading $pkg";
2732
2733 if (my $cb = $pkg->can ("unload")) {
2734 eval {
2735 $cb->($pkg);
2736 1
2737 } or warn "$pkg unloaded, but with errors: $@";
2738 } 3604 }
2739 3605
2740 warn "... nuking $pkg"; 3606 warn "cancelling all extension coros";
2741 Symbol::delete_package $pkg; 3607 $_->cancel for values %EXT_CORO;
2742 } 3608 %EXT_CORO = ();
2743 3609
2744 warn "unloading all perl modules loaded from $LIBDIR"; 3610 warn "removing commands";
2745 while (my ($k, $v) = each %INC) { 3611 %COMMAND = ();
2746 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2747 3612
3613 warn "removing ext/exti commands";
3614 %EXTCMD = ();
3615 %EXTICMD = ();
3616
3617 warn "unloading/nuking all extensions";
3618 for my $pkg (@EXTS) {
2748 warn "... unloading $k"; 3619 warn "... unloading $pkg";
2749 delete $INC{$k};
2750 3620
2751 $k =~ s/\.pm$//;
2752 $k =~ s/\//::/g;
2753
2754 if (my $cb = $k->can ("unload_module")) { 3621 if (my $cb = $pkg->can ("unload")) {
3622 eval {
2755 $cb->(); 3623 $cb->($pkg);
3624 1
3625 } or warn "$pkg unloaded, but with errors: $@";
3626 }
3627
3628 warn "... clearing $pkg";
3629 clear_package $pkg;
2756 } 3630 }
2757 3631
2758 Symbol::delete_package $k; 3632 warn "unloading all perl modules loaded from $LIBDIR";
3633 while (my ($k, $v) = each %INC) {
3634 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3635
3636 warn "... unloading $k";
3637 delete $INC{$k};
3638
3639 $k =~ s/\.pm$//;
3640 $k =~ s/\//::/g;
3641
3642 if (my $cb = $k->can ("unload_module")) {
3643 $cb->();
3644 }
3645
3646 clear_package $k;
2759 } 3647 }
2760 3648
2761 warn "getting rid of safe::, as good as possible"; 3649 warn "getting rid of safe::, as good as possible";
2762 Symbol::delete_package "safe::$_" 3650 clear_package "safe::$_"
2763 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3651 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2764 3652
2765 warn "unloading cf.pm \"a bit\""; 3653 warn "unloading cf.pm \"a bit\"";
2766 delete $INC{"cf.pm"}; 3654 delete $INC{"cf.pm"};
2767 delete $INC{"cf/pod.pm"}; 3655 delete $INC{"cf/pod.pm"};
2768 3656
2769 # don't, removes xs symbols, too, 3657 # don't, removes xs symbols, too,
2770 # and global variables created in xs 3658 # and global variables created in xs
2771 #Symbol::delete_package __PACKAGE__; 3659 #clear_package __PACKAGE__;
2772 3660
2773 warn "unload completed, starting to reload now"; 3661 warn "unload completed, starting to reload now";
2774 3662
2775 warn "reloading cf.pm"; 3663 warn "reloading cf.pm";
2776 require cf; 3664 require cf;
2777 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3665 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2778 3666
2779 warn "loading config and database again"; 3667 warn "loading config and database again";
2780 cf::cfg_load; 3668 cf::reload_config;
2781 3669
2782 warn "loading extensions"; 3670 warn "loading extensions";
2783 cf::load_extensions; 3671 cf::load_extensions;
2784 3672
2785 warn "reattaching attachments to objects/players"; 3673 warn "reattaching attachments to objects/players";
2786 _global_reattach; # objects, sockets 3674 _global_reattach; # objects, sockets
2787 warn "reattaching attachments to maps"; 3675 warn "reattaching attachments to maps";
2788 reattach $_ for values %MAP; 3676 reattach $_ for values %MAP;
2789 warn "reattaching attachments to players"; 3677 warn "reattaching attachments to players";
2790 reattach $_ for values %PLAYER; 3678 reattach $_ for values %PLAYER;
2791 3679
2792 warn "leaving sync_job"; 3680 warn "leaving sync_job";
2793 3681
2794 1 3682 1
2795 } or do { 3683 } or do {
2796 warn $@; 3684 warn $@;
2797 warn "error while reloading, exiting."; 3685 cf::cleanup "error while reloading, exiting.";
2798 exit 1;
2799 }; 3686 };
2800 3687
2801 warn "reloaded"; 3688 warn "reloaded";
3689 --$RELOAD;
3690 }
2802}; 3691};
2803 3692
2804our $RELOAD_WATCHER; # used only during reload 3693our $RELOAD_WATCHER; # used only during reload
2805 3694
2806sub reload_perl() { 3695sub reload_perl() {
2807 # doing reload synchronously and two reloads happen back-to-back, 3696 # doing reload synchronously and two reloads happen back-to-back,
2808 # coro crashes during coro_state_free->destroy here. 3697 # coro crashes during coro_state_free->destroy here.
2809 3698
2810 $RELOAD_WATCHER ||= Event->timer ( 3699 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
2811 reentrant => 0,
2812 after => 0,
2813 data => WF_AUTOCANCEL,
2814 cb => sub {
2815 do_reload_perl; 3700 do_reload_perl;
2816 undef $RELOAD_WATCHER; 3701 undef $RELOAD_WATCHER;
2817 },
2818 ); 3702 };
2819} 3703}
2820 3704
2821register_command "reload" => sub { 3705register_command "reload" => sub {
2822 my ($who, $arg) = @_; 3706 my ($who, $arg) = @_;
2823 3707
2824 if ($who->flag (FLAG_WIZ)) { 3708 if ($who->flag (FLAG_WIZ)) {
2825 $who->message ("reloading server."); 3709 $who->message ("reloading server.");
3710 async {
3711 $Coro::current->{desc} = "perl_reload";
2826 async { reload_perl }; 3712 reload_perl;
3713 };
2827 } 3714 }
2828}; 3715};
2829 3716
2830unshift @INC, $LIBDIR; 3717unshift @INC, $LIBDIR;
2831 3718
… …
2833 3720
2834our @WAIT_FOR_TICK; 3721our @WAIT_FOR_TICK;
2835our @WAIT_FOR_TICK_BEGIN; 3722our @WAIT_FOR_TICK_BEGIN;
2836 3723
2837sub wait_for_tick { 3724sub wait_for_tick {
2838 return unless $TICK_WATCHER->is_active;
2839 return if $Coro::current == $Coro::main; 3725 return if tick_inhibit || $Coro::current == $Coro::main;
2840 3726
2841 my $signal = new Coro::Signal; 3727 my $signal = new Coro::Signal;
2842 push @WAIT_FOR_TICK, $signal; 3728 push @WAIT_FOR_TICK, $signal;
2843 $signal->wait; 3729 $signal->wait;
2844} 3730}
2845 3731
2846sub wait_for_tick_begin { 3732sub wait_for_tick_begin {
2847 return unless $TICK_WATCHER->is_active;
2848 return if $Coro::current == $Coro::main; 3733 return if tick_inhibit || $Coro::current == $Coro::main;
2849 3734
2850 my $signal = new Coro::Signal; 3735 my $signal = new Coro::Signal;
2851 push @WAIT_FOR_TICK_BEGIN, $signal; 3736 push @WAIT_FOR_TICK_BEGIN, $signal;
2852 $signal->wait; 3737 $signal->wait;
2853} 3738}
2854 3739
2855 my $min = 1e6;#d# 3740sub tick {
2856 my $avg = 10;
2857$TICK_WATCHER = Event->timer (
2858 reentrant => 0,
2859 parked => 1,
2860 prio => 0,
2861 at => $NEXT_TICK || $TICK,
2862 data => WF_AUTOCANCEL,
2863 cb => sub {
2864 if ($Coro::current != $Coro::main) { 3741 if ($Coro::current != $Coro::main) {
2865 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3742 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2866 unless ++$bug_warning > 10; 3743 unless ++$bug_warning > 10;
2867 return; 3744 return;
2868 } 3745 }
2869 3746
2870 $NOW = $tick_start = Event::time;
2871
2872 cf::server_tick; # one server iteration 3747 cf::server_tick; # one server iteration
2873 3748
2874 0 && sync_job {#d# 3749 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2875 for(1..10) { 3750 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2876 my $t = Event::time; 3751 Coro::async_pool {
2877 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3752 $Coro::current->{desc} = "runtime saver";
2878 or die; 3753 write_runtime_sync
2879 3754 or warn "ERROR: unable to write runtime file: $!";
2880 $map->width (50);
2881 $map->height (50);
2882 $map->alloc;
2883 $map->_load_objects ("/tmp/x.map", 1);
2884 my $t = Event::time - $t;
2885
2886 #next unless $t < 0.0013;#d#
2887 if ($t < $min) {
2888 $min = $t;
2889 }
2890 $avg = $avg * 0.99 + $t * 0.01;
2891 }
2892 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2893 exit 0;
2894 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2895 }; 3755 };
3756 }
2896 3757
2897 $RUNTIME += $TICK;
2898 $NEXT_TICK += $TICK;
2899
2900 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2901 $NEXT_RUNTIME_WRITE = $NOW + 10;
2902 Coro::async_pool {
2903 write_runtime
2904 or warn "ERROR: unable to write runtime file: $!";
2905 };
2906 }
2907
2908# my $AFTER = Event::time;
2909# warn $AFTER - $NOW;#d#
2910
2911 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3758 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2912 $sig->send; 3759 $sig->send;
2913 } 3760 }
2914 while (my $sig = shift @WAIT_FOR_TICK) { 3761 while (my $sig = shift @WAIT_FOR_TICK) {
2915 $sig->send; 3762 $sig->send;
2916 } 3763 }
2917 3764
2918 $NOW = Event::time; 3765 $LOAD = ($NOW - $TICK_START) / $TICK;
2919
2920 # if we are delayed by four ticks or more, skip them all
2921 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2922
2923 $TICK_WATCHER->at ($NEXT_TICK);
2924 $TICK_WATCHER->start;
2925
2926 $LOAD = ($NOW - $tick_start) / $TICK;
2927 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3766 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2928 3767
2929 _post_tick; 3768 if (0) {
2930 3769 if ($NEXT_TICK) {
2931 3770 my $jitter = $TICK_START - $NEXT_TICK;
3771 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3772 warn "jitter $JITTER\n";#d#
3773 }
2932 }, 3774 }
2933); 3775}
2934 3776
2935{ 3777{
2936 BDB::max_poll_time $TICK * 0.1; 3778 # configure BDB
2937 $BDB_POLL_WATCHER = Event->io ( 3779
2938 reentrant => 0,
2939 fd => BDB::poll_fileno,
2940 poll => 'r',
2941 prio => 0,
2942 data => WF_AUTOCANCEL,
2943 cb => \&BDB::poll_cb,
2944 );
2945 BDB::min_parallel 8; 3780 BDB::min_parallel 8;
2946 3781 BDB::max_poll_reqs $TICK * 0.1;
2947 BDB::set_sync_prepare { 3782 $AnyEvent::BDB::WATCHER->priority (1);
2948 my $status;
2949 my $current = $Coro::current;
2950 (
2951 sub {
2952 $status = $!;
2953 $current->ready; undef $current;
2954 },
2955 sub {
2956 Coro::schedule while defined $current;
2957 $! = $status;
2958 },
2959 )
2960 };
2961 3783
2962 unless ($DB_ENV) { 3784 unless ($DB_ENV) {
2963 $DB_ENV = BDB::db_env_create; 3785 $DB_ENV = BDB::db_env_create;
3786 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3787 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3788 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3789 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3790 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2964 3791
2965 cf::sync_job { 3792 cf::sync_job {
2966 eval { 3793 eval {
2967 BDB::db_env_open 3794 BDB::db_env_open
2968 $DB_ENV, 3795 $DB_ENV,
… …
2970 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3797 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2971 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3798 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2972 0666; 3799 0666;
2973 3800
2974 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3801 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2975
2976 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2977 $DB_ENV->set_lk_detect;
2978 }; 3802 };
2979 3803
2980 cf::cleanup "db_env_open(db): $@" if $@; 3804 cf::cleanup "db_env_open(db): $@" if $@;
2981 }; 3805 };
2982 } 3806 }
3807
3808 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3809 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3810 };
3811 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3812 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3813 };
3814 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3815 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3816 };
2983} 3817}
2984 3818
2985{ 3819{
3820 # configure IO::AIO
3821
2986 IO::AIO::min_parallel 8; 3822 IO::AIO::min_parallel 8;
2987
2988 undef $Coro::AIO::WATCHER;
2989 IO::AIO::max_poll_time $TICK * 0.1; 3823 IO::AIO::max_poll_time $TICK * 0.1;
2990 $AIO_POLL_WATCHER = Event->io ( 3824 undef $AnyEvent::AIO::WATCHER;
2991 reentrant => 0,
2992 data => WF_AUTOCANCEL,
2993 fd => IO::AIO::poll_fileno,
2994 poll => 'r',
2995 prio => 6,
2996 cb => \&IO::AIO::poll_cb,
2997 );
2998} 3825}
2999 3826
3000my $_log_backtrace; 3827my $_log_backtrace;
3001 3828
3002sub _log_backtrace { 3829sub _log_backtrace {
… …
3006 3833
3007 # limit the # of concurrent backtraces 3834 # limit the # of concurrent backtraces
3008 if ($_log_backtrace < 2) { 3835 if ($_log_backtrace < 2) {
3009 ++$_log_backtrace; 3836 ++$_log_backtrace;
3010 async { 3837 async {
3838 $Coro::current->{desc} = "abt $msg";
3839
3011 my @bt = fork_call { 3840 my @bt = fork_call {
3012 @addr = map { sprintf "%x", $_ } @addr; 3841 @addr = map { sprintf "%x", $_ } @addr;
3013 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3842 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3014 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3843 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3015 or die "addr2line: $!"; 3844 or die "addr2line: $!";

Diff Legend

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