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.282 by elmex, Tue Jun 19 18:15:34 2007 UTC vs.
Revision 1.458 by root, Sat Dec 13 20:34:37 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
37use Guard ();
15use Coro 3.61 (); 38use Coro ();
16use Coro::State; 39use Coro::State;
17use Coro::Handle; 40use Coro::Handle;
41use Coro::EV;
18use Coro::Event; 42use Coro::AnyEvent;
19use Coro::Timer; 43use Coro::Timer;
20use Coro::Signal; 44use Coro::Signal;
21use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::AnyEvent;
22use Coro::AIO; 47use Coro::AIO;
48use Coro::BDB 1.6;
23use Coro::Storable; 49use Coro::Storable;
50use Coro::Util ();
24 51
52use JSON::XS 2.01 ();
25use BDB (); 53use BDB ();
26use Data::Dumper; 54use Data::Dumper;
27use Digest::MD5; 55use Digest::MD5;
28use Fcntl; 56use Fcntl;
29use YAML::Syck (); 57use YAML ();
30use IO::AIO 2.32 (); 58use IO::AIO ();
31use Time::HiRes; 59use Time::HiRes;
32use Compress::LZF; 60use Compress::LZF;
61use Digest::MD5 ();
62
63AnyEvent::detect;
33 64
34# configure various modules to our taste 65# configure various modules to our taste
35# 66#
36$Storable::canonical = 1; # reduce rsync transfers 67$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 68Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
69
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71
72# make sure c-lzf reinitialises itself
73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39
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
46 75
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 76sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
48 77
49our %COMMAND = (); 78our %COMMAND = ();
50our %COMMAND_TIME = (); 79our %COMMAND_TIME = ();
51 80
52our @EXTS = (); # list of extension package names 81our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 82our %EXTCMD = ();
83our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 84our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 85our %EXT_MAP = (); # pluggable maps
56 86
57our $RELOAD; # number of reloads so far 87our $RELOAD; # number of reloads so far, non-zero while in reload
58our @EVENT; 88our @EVENT;
59 89
60our $CONFDIR = confdir; 90our $CONFDIR = confdir;
61our $DATADIR = datadir; 91our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext"; 92our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod"; 93our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir; 94our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir; 95our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir; 96our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 97our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir; 98our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random"; 99our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db"; 100our $BDBDIR = "$LOCALDIR/db";
101our $PIDFILE = "$LOCALDIR/pid";
102our $RUNTIMEFILE = "$LOCALDIR/runtime";
103
104our %RESOURCE;
71 105
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 106our $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 107our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
76our $NEXT_TICK; 108our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 109our $USE_FSYNC = 1; # use fsync to write maps - default off
79 110
111our $BDB_DEADLOCK_WATCHER;
112our $BDB_CHECKPOINT_WATCHER;
80our $BDB_POLL_WATCHER; 113our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 114our $DB_ENV;
82 115
83our %CFG; 116our %CFG;
84 117
85our $UPTIME; $UPTIME ||= time; 118our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 119our $RUNTIME;
120our $NOW;
87 121
88our %PLAYER; # all users 122our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 123our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 124our $LINK_MAP; # the special {link} map, which is always available
91 125
92# used to convert map paths into valid unix filenames by replacing / by ∕ 126# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 127our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 128
95our $LOAD; # a number between 0 (idle) and 1 (too many objects) 129our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing 130our $LOADAVG; # same thing, but with alpha-smoothing
131our $JITTER; # average jitter
97our $tick_start; # for load detecting purposes 132our $TICK_START; # for load detecting purposes
133
134our @POST_INIT;
135
136our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow)
98 137
99binmode STDOUT; 138binmode STDOUT;
100binmode STDERR; 139binmode STDERR;
101 140
102# read virtual server time, if available 141# read virtual server time, if available
103unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 142unless ($RUNTIME || !-e $RUNTIMEFILE) {
104 open my $fh, "<", "$LOCALDIR/runtime" 143 open my $fh, "<", $RUNTIMEFILE
105 or die "unable to read runtime file: $!"; 144 or die "unable to read $RUNTIMEFILE file: $!";
106 $RUNTIME = <$fh> + 0.; 145 $RUNTIME = <$fh> + 0.;
107} 146}
108 147
109mkdir $_ 148mkdir $_
110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 149 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
… …
155 194
156The raw value load value from the last tick. 195The raw value load value from the last tick.
157 196
158=item %cf::CFG 197=item %cf::CFG
159 198
160Configuration for the server, loaded from C</etc/crossfire/config>, or 199Configuration for the server, loaded from C</etc/deliantra-server/config>, or
161from wherever your confdir points to. 200from wherever your confdir points to.
162 201
163=item cf::wait_for_tick, cf::wait_for_tick_begin 202=item cf::wait_for_tick, cf::wait_for_tick_begin
164 203
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 204These 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 205returns 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. 206per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168 207
208=item @cf::INVOKE_RESULTS
209
210This array contains the results of the last C<invoke ()> call. When
211C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
212that call.
213
169=back 214=back
170 215
171=cut 216=cut
172 217
173BEGIN { 218BEGIN {
… …
177 $msg .= "\n" 222 $msg .= "\n"
178 unless $msg =~ /\n$/; 223 unless $msg =~ /\n$/;
179 224
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 225 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181 226
182 utf8::encode $msg;
183 LOG llevError, $msg; 227 LOG llevError, $msg;
184 }; 228 };
185} 229}
230
231$Coro::State::DIEHOOK = sub {
232 return unless $^S eq 0; # "eq", not "=="
233
234 if ($Coro::current == $Coro::main) {#d#
235 warn "DIEHOOK called in main context, Coro bug?\n";#d#
236 return;#d#
237 }#d#
238
239 # kill coroutine otherwise
240 warn Carp::longmess $_[0];
241 Coro::terminate
242};
243
244$SIG{__DIE__} = sub { }; #d#?
186 245
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 246@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 247@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 248@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 249@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
197for my $pkg (qw( 256for my $pkg (qw(
198 cf::global cf::attachable 257 cf::global cf::attachable
199 cf::object cf::object::player 258 cf::object cf::object::player
200 cf::client cf::player 259 cf::client cf::player
201 cf::arch cf::living 260 cf::arch cf::living
261 cf::map cf::mapspace
202 cf::map cf::party cf::region 262 cf::party cf::region
203)) { 263)) {
204 no strict 'refs';
205 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 264 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
206} 265}
207 266
208$Event::DIED = sub { 267$EV::DIED = sub {
209 warn "error in event callback: @_"; 268 warn "error in event callback: @_";
210}; 269};
211 270
212############################################################################# 271#############################################################################
213 272
… …
236 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 295 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
237 $d 296 $d
238 } || "[unable to dump $_[0]: '$@']"; 297 } || "[unable to dump $_[0]: '$@']";
239} 298}
240 299
241use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
242
243=item $ref = cf::from_json $json 300=item $ref = cf::decode_json $json
244 301
245Converts a JSON string into the corresponding perl data structure. 302Converts a JSON string into the corresponding perl data structure.
246 303
247=item $json = cf::to_json $ref 304=item $json = cf::encode_json $ref
248 305
249Converts a perl data structure into its JSON representation. 306Converts a perl data structure into its JSON representation.
250 307
308=cut
309
310our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
311
312sub encode_json($) { $json_coder->encode ($_[0]) }
313sub decode_json($) { $json_coder->decode ($_[0]) }
314
315=item cf::post_init { BLOCK }
316
317Execute the given codeblock, I<after> all extensions have been (re-)loaded,
318but I<before> the server starts ticking again.
319
320The cdoeblock will have a single boolean argument to indicate whether this
321is a reload or not.
322
323=cut
324
325sub post_init(&) {
326 push @POST_INIT, shift;
327}
328
251=item cf::lock_wait $string 329=item cf::lock_wait $string
252 330
253Wait until the given lock is available. See cf::lock_acquire. 331Wait until the given lock is available. See cf::lock_acquire.
254 332
255=item my $lock = cf::lock_acquire $string 333=item my $lock = cf::lock_acquire $string
256 334
257Wait until the given lock is available and then acquires it and returns 335Wait until the given lock is available and then acquires it and returns
258a Coro::guard object. If the guard object gets destroyed (goes out of scope, 336a L<Guard> object. If the guard object gets destroyed (goes out of scope,
259for example when the coroutine gets canceled), the lock is automatically 337for example when the coroutine gets canceled), the lock is automatically
260returned. 338returned.
261 339
340Locks are *not* recursive, locking from the same coro twice results in a
341deadlocked coro.
342
262Lock names should begin with a unique identifier (for example, cf::map::find 343Lock names should begin with a unique identifier (for example, cf::map::find
263uses map_find and cf::map::load uses map_load). 344uses map_find and cf::map::load uses map_load).
264 345
265=item $locked = cf::lock_active $string 346=item $locked = cf::lock_active $string
266 347
267Return true if the lock is currently active, i.e. somebody has locked it. 348Return true if the lock is currently active, i.e. somebody has locked it.
268 349
269=cut 350=cut
270 351
271our %LOCK; 352our %LOCK;
353our %LOCKER;#d#
272 354
273sub lock_wait($) { 355sub lock_wait($) {
274 my ($key) = @_; 356 my ($key) = @_;
275 357
358 if ($LOCKER{$key} == $Coro::current) {#d#
359 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
360 return;#d#
361 }#d#
362
276 # wait for lock, if any 363 # wait for lock, if any
277 while ($LOCK{$key}) { 364 while ($LOCK{$key}) {
365 #local $Coro::current->{desc} = "$Coro::current->{desc} <waiting for lock $key>";
278 push @{ $LOCK{$key} }, $Coro::current; 366 push @{ $LOCK{$key} }, $Coro::current;
279 Coro::schedule; 367 Coro::schedule;
280 } 368 }
281} 369}
282 370
… …
285 373
286 # wait, to be sure we are not locked 374 # wait, to be sure we are not locked
287 lock_wait $key; 375 lock_wait $key;
288 376
289 $LOCK{$key} = []; 377 $LOCK{$key} = [];
378 $LOCKER{$key} = $Coro::current;#d#
290 379
291 Coro::guard { 380 Guard::guard {
381 delete $LOCKER{$key};#d#
292 # wake up all waiters, to be on the safe side 382 # wake up all waiters, to be on the safe side
293 $_->ready for @{ delete $LOCK{$key} }; 383 $_->ready for @{ delete $LOCK{$key} };
294 } 384 }
295} 385}
296 386
… …
299 389
300 ! ! $LOCK{$key} 390 ! ! $LOCK{$key}
301} 391}
302 392
303sub freeze_mainloop { 393sub freeze_mainloop {
304 return unless $TICK_WATCHER->is_active; 394 tick_inhibit_inc;
305 395
306 my $guard = Coro::guard { 396 &Guard::guard (\&tick_inhibit_dec);
307 $TICK_WATCHER->start; 397}
398
399=item cf::periodic $interval, $cb
400
401Like EV::periodic, but randomly selects a starting point so that the actions
402get spread over timer.
403
404=cut
405
406sub periodic($$) {
407 my ($interval, $cb) = @_;
408
409 my $start = rand List::Util::min 180, $interval;
410
411 EV::periodic $start, $interval, 0, $cb
412}
413
414=item cf::get_slot $time[, $priority[, $name]]
415
416Allocate $time seconds of blocking CPU time at priority C<$priority>:
417This call blocks and returns only when you have at least C<$time> seconds
418of cpu time till the next tick. The slot is only valid till the next cede.
419
420The optional C<$name> can be used to identify the job to run. It might be
421used for statistical purposes and should identify the same time-class.
422
423Useful for short background jobs.
424
425=cut
426
427our @SLOT_QUEUE;
428our $SLOT_QUEUE;
429
430$SLOT_QUEUE->cancel if $SLOT_QUEUE;
431$SLOT_QUEUE = Coro::async {
432 $Coro::current->desc ("timeslot manager");
433
434 my $signal = new Coro::Signal;
435
436 while () {
437 next_job:
438 my $avail = cf::till_tick;
439 if ($avail > 0.01) {
440 for (0 .. $#SLOT_QUEUE) {
441 if ($SLOT_QUEUE[$_][0] < $avail) {
442 my $job = splice @SLOT_QUEUE, $_, 1, ();
443 $job->[2]->send;
444 Coro::cede;
445 goto next_job;
446 }
447 }
448 }
449
450 if (@SLOT_QUEUE) {
451 # we do not use wait_for_tick() as it returns immediately when tick is inactive
452 push @cf::WAIT_FOR_TICK, $signal;
453 $signal->wait;
454 } else {
455 Coro::schedule;
456 }
308 }; 457 }
309 $TICK_WATCHER->stop; 458};
310 $guard 459
460sub get_slot($;$$) {
461 return if tick_inhibit || $Coro::current == $Coro::main;
462
463 my ($time, $pri, $name) = @_;
464
465 $time = $TICK * .6 if $time > $TICK * .6;
466 my $sig = new Coro::Signal;
467
468 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
469 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
470 $SLOT_QUEUE->ready;
471 $sig->wait;
311} 472}
312 473
313=item cf::async { BLOCK } 474=item cf::async { BLOCK }
314 475
315Currently the same as Coro::async_pool, meaning you cannot use 476Currently the same as Coro::async_pool, meaning you cannot use
… …
320 481
321BEGIN { *async = \&Coro::async_pool } 482BEGIN { *async = \&Coro::async_pool }
322 483
323=item cf::sync_job { BLOCK } 484=item cf::sync_job { BLOCK }
324 485
325The design of Crossfire TRT requires that the main coroutine ($Coro::main) 486The design of Deliantra requires that the main coroutine ($Coro::main)
326is always able to handle events or runnable, as Crossfire TRT is only 487is always able to handle events or runnable, as Deliantra is only
327partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 488partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
328acceptable. 489acceptable.
329 490
330If it must be done, put the blocking parts into C<sync_job>. This will run 491If it must be done, put the blocking parts into C<sync_job>. This will run
331the given BLOCK in another coroutine while waiting for the result. The 492the given BLOCK in another coroutine while waiting for the result. The
… …
336 497
337sub sync_job(&) { 498sub sync_job(&) {
338 my ($job) = @_; 499 my ($job) = @_;
339 500
340 if ($Coro::current == $Coro::main) { 501 if ($Coro::current == $Coro::main) {
341 my $time = Event::time; 502 my $time = EV::time;
342 503
343 # this is the main coro, too bad, we have to block 504 # this is the main coro, too bad, we have to block
344 # till the operation succeeds, freezing the server :/ 505 # till the operation succeeds, freezing the server :/
345 506
346 # TODO: use suspend/resume instead 507 LOG llevError, Carp::longmess "sync job";#d#
347 # (but this is cancel-safe) 508
348 my $freeze_guard = freeze_mainloop; 509 my $freeze_guard = freeze_mainloop;
349 510
350 my $busy = 1; 511 my $busy = 1;
351 my @res; 512 my @res;
352 513
353 (async { 514 (async {
515 $Coro::current->desc ("sync job coro");
354 @res = eval { $job->() }; 516 @res = eval { $job->() };
355 warn $@ if $@; 517 warn $@ if $@;
356 undef $busy; 518 undef $busy;
357 })->prio (Coro::PRIO_MAX); 519 })->prio (Coro::PRIO_MAX);
358 520
359 while ($busy) { 521 while ($busy) {
360 Coro::cede or Event::one_event; 522 if (Coro::nready) {
523 Coro::cede_notself;
524 } else {
525 EV::loop EV::LOOP_ONESHOT;
361 } 526 }
527 }
362 528
363 $time = Event::time - $time; 529 my $time = EV::time - $time;
364 530
365 LOG llevError | logBacktrace, Carp::longmess "long sync job"
366 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
367
368 $tick_start += $time; # do not account sync jobs to server load 531 $TICK_START += $time; # do not account sync jobs to server load
369 532
370 wantarray ? @res : $res[0] 533 wantarray ? @res : $res[0]
371 } else { 534 } else {
372 # we are in another coroutine, how wonderful, everything just works 535 # we are in another coroutine, how wonderful, everything just works
373 536
… …
398=item fork_call { }, $args 561=item fork_call { }, $args
399 562
400Executes the given code block with the given arguments in a seperate 563Executes the given code block with the given arguments in a seperate
401process, returning the results. Everything must be serialisable with 564process, returning the results. Everything must be serialisable with
402Coro::Storable. May, of course, block. Note that the executed sub may 565Coro::Storable. May, of course, block. Note that the executed sub may
403never block itself or use any form of Event handling. 566never block itself or use any form of event handling.
404 567
405=cut 568=cut
406 569
407sub fork_call(&@) { 570sub fork_call(&@) {
408 my ($cb, @args) = @_; 571 my ($cb, @args) = @_;
409 572
410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 573 # we seemingly have to make a local copy of the whole thing,
411# or die "socketpair: $!"; 574 # otherwise perl prematurely frees the stuff :/
412 pipe my $fh1, my $fh2 575 # TODO: investigate and fix (likely this will be rather laborious)
413 or die "pipe: $!";
414 576
415 if (my $pid = fork) { 577 my @res = Coro::Util::fork_eval {
416 close $fh2;
417
418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
419 $res = Coro::Storable::thaw $res;
420
421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
422
423 die $$res unless "ARRAY" eq ref $res;
424
425 return wantarray ? @$res : $res->[-1];
426 } else {
427 reset_signals; 578 reset_signals;
428 local $SIG{__WARN__}; 579 &$cb
429 local $SIG{__DIE__}; 580 }, @args;
430 eval {
431 close $fh1;
432 581
433 my @res = eval { $cb->(@args) }; 582 wantarray ? @res : $res[-1]
434 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res); 583}
435 };
436 584
437 warn $@ if $@; 585=item $coin = coin_from_name $name
438 _exit 0; 586
439 } 587=cut
588
589our %coin_alias = (
590 "silver" => "silvercoin",
591 "silvercoin" => "silvercoin",
592 "silvercoins" => "silvercoin",
593 "gold" => "goldcoin",
594 "goldcoin" => "goldcoin",
595 "goldcoins" => "goldcoin",
596 "platinum" => "platinacoin",
597 "platinumcoin" => "platinacoin",
598 "platinumcoins" => "platinacoin",
599 "platina" => "platinacoin",
600 "platinacoin" => "platinacoin",
601 "platinacoins" => "platinacoin",
602 "royalty" => "royalty",
603 "royalties" => "royalty",
604);
605
606sub coin_from_name($) {
607 $coin_alias{$_[0]}
608 ? cf::arch::find $coin_alias{$_[0]}
609 : undef
440} 610}
441 611
442=item $value = cf::db_get $family => $key 612=item $value = cf::db_get $family => $key
443 613
444Returns a single value from the environment database. 614Returns a single value from the environment database.
… …
446=item cf::db_put $family => $key => $value 616=item cf::db_put $family => $key => $value
447 617
448Stores the given C<$value> in the family. It can currently store binary 618Stores the given C<$value> in the family. It can currently store binary
449data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 619data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450 620
621=item $db = cf::db_table "name"
622
623Create and/or open a new database table. The string must not be "db" and must be unique
624within each server.
625
451=cut 626=cut
627
628sub db_table($) {
629 my ($name) = @_;
630 my $db = BDB::db_create $DB_ENV;
631
632 eval {
633 $db->set_flags (BDB::CHKSUM);
634
635 utf8::encode $name;
636 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
637 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
638 cf::cleanup "db_open(db): $!" if $!;
639 };
640 cf::cleanup "db_open(db): $@" if $@;
641
642 $db
643}
452 644
453our $DB; 645our $DB;
454 646
455sub db_init { 647sub db_init {
456 unless ($DB) {
457 $DB = BDB::db_create $DB_ENV;
458
459 cf::sync_job { 648 cf::sync_job {
460 eval { 649 $DB ||= db_table "db";
461 $DB->set_flags (BDB::CHKSUM);
462
463 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465 cf::cleanup "db_open(db): $!" if $!;
466 };
467 cf::cleanup "db_open(db): $@" if $@;
468 };
469 } 650 };
470} 651}
471 652
472sub db_get($$) { 653sub db_get($$) {
473 my $key = "$_[0]/$_[1]"; 654 my $key = "$_[0]/$_[1]";
474 655
… …
524 if (1) { 705 if (1) {
525 $md5 = 706 $md5 =
526 join "\x00", 707 join "\x00",
527 $processversion, 708 $processversion,
528 map { 709 map {
529 Coro::cede; 710 cf::cede_to_tick;
530 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 711 ($src->[$_], Digest::MD5::md5_hex $data[$_])
531 } 0.. $#$src; 712 } 0.. $#$src;
532 713
533 714
534 my $dbmd5 = db_get cache => "$id/md5"; 715 my $dbmd5 = db_get cache => "$id/md5";
… …
572 753
573############################################################################# 754#############################################################################
574 755
575=head2 ATTACHABLE OBJECTS 756=head2 ATTACHABLE OBJECTS
576 757
577Many objects in crossfire are so-called attachable objects. That means you can 758Many objects in deliantra are so-called attachable objects. That means you can
578attach callbacks/event handlers (a collection of which is called an "attachment") 759attach callbacks/event handlers (a collection of which is called an "attachment")
579to it. All such attachable objects support the following methods. 760to it. All such attachable objects support the following methods.
580 761
581In the following description, CLASS can be any of C<global>, C<object> 762In the following description, CLASS can be any of C<global>, C<object>
582C<player>, C<client> or C<map> (i.e. the attachable objects in 763C<player>, C<client> or C<map> (i.e. the attachable objects in
583Crossfire TRT). 764Deliantra).
584 765
585=over 4 766=over 4
586 767
587=item $attachable->attach ($attachment, key => $value...) 768=item $attachable->attach ($attachment, key => $value...)
588 769
… …
632=item cf::CLASS::attachment $name, ... 813=item cf::CLASS::attachment $name, ...
633 814
634Register an attachment by C<$name> through which attachable objects of the 815Register an attachment by C<$name> through which attachable objects of the
635given CLASS can refer to this attachment. 816given CLASS can refer to this attachment.
636 817
637Some classes such as crossfire maps and objects can specify attachments 818Some classes such as deliantra maps and objects can specify attachments
638that are attached at load/instantiate time, thus the need for a name. 819that are attached at load/instantiate time, thus the need for a name.
639 820
640These calls expect any number of the following handler/hook descriptions: 821These calls expect any number of the following handler/hook descriptions:
641 822
642=over 4 823=over 4
… …
840 "; 1021 ";
841 die if $@; 1022 die if $@;
842} 1023}
843 1024
844our $override; 1025our $override;
845our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 1026our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
846 1027
847sub override { 1028sub override {
848 $override = 1; 1029 $override = 1;
849 @invoke_results = (); 1030 @INVOKE_RESULTS = (@_);
850} 1031}
851 1032
852sub do_invoke { 1033sub do_invoke {
853 my $event = shift; 1034 my $event = shift;
854 my $callbacks = shift; 1035 my $callbacks = shift;
855 1036
856 @invoke_results = (); 1037 @INVOKE_RESULTS = ();
857 1038
858 local $override; 1039 local $override;
859 1040
860 for (@$callbacks) { 1041 for (@$callbacks) {
861 eval { &{$_->[1]} }; 1042 eval { &{$_->[1]} };
… …
870 } 1051 }
871 1052
872 0 1053 0
873} 1054}
874 1055
875=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1056=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
876 1057
877=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1058=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
878 1059
879Generate an object-specific event with the given arguments. 1060Generate an object-specific event with the given arguments.
880 1061
881This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1062This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
882removed in future versions), and there is no public API to access override 1063removed in future versions), and there is no public API to access override
883results (if you must, access C<@cf::invoke_results> directly). 1064results (if you must, access C<@cf::INVOKE_RESULTS> directly).
884 1065
885=back 1066=back
886 1067
887=cut 1068=cut
888 1069
889############################################################################# 1070#############################################################################
890# object support 1071# object support
1072
1073sub _object_equal($$);
1074sub _object_equal($$) {
1075 my ($a, $b) = @_;
1076
1077 return 0 unless (ref $a) eq (ref $b);
1078
1079 if ("HASH" eq ref $a) {
1080 my @ka = keys %$a;
1081 my @kb = keys %$b;
1082
1083 return 0 if @ka != @kb;
1084
1085 for (0 .. $#ka) {
1086 return 0 unless $ka[$_] eq $kb[$_];
1087 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1088 }
1089
1090 } elsif ("ARRAY" eq ref $a) {
1091
1092 return 0 if @$a != @$b;
1093
1094 for (0 .. $#$a) {
1095 return 0 unless _object_equal $a->[$_], $b->[$_];
1096 }
1097
1098 } elsif ($a ne $b) {
1099 return 0;
1100 }
1101
1102 1
1103}
1104
1105our $SLOW_MERGES;#d#
1106sub _can_merge {
1107 my ($ob1, $ob2) = @_;
1108
1109 ++$SLOW_MERGES;#d#
1110
1111 # we do the slow way here
1112 return _object_equal $ob1, $ob2
1113}
891 1114
892sub reattach { 1115sub reattach {
893 # basically do the same as instantiate, without calling instantiate 1116 # basically do the same as instantiate, without calling instantiate
894 my ($obj) = @_; 1117 my ($obj) = @_;
895 1118
1119 # no longer needed after getting rid of delete_package?
896 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1120 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
897 1121
898 my $registry = $obj->registry; 1122 my $registry = $obj->registry;
899 1123
900 @$registry = (); 1124 @$registry = ();
901 1125
… …
916cf::attachable->attach ( 1140cf::attachable->attach (
917 prio => -1000000, 1141 prio => -1000000,
918 on_instantiate => sub { 1142 on_instantiate => sub {
919 my ($obj, $data) = @_; 1143 my ($obj, $data) = @_;
920 1144
921 $data = from_json $data; 1145 $data = decode_json $data;
922 1146
923 for (@$data) { 1147 for (@$data) {
924 my ($name, $args) = @$_; 1148 my ($name, $args) = @$_;
925 1149
926 $obj->attach ($name, %{$args || {} }); 1150 $obj->attach ($name, %{$args || {} });
… …
942sub object_freezer_save { 1166sub object_freezer_save {
943 my ($filename, $rdata, $objs) = @_; 1167 my ($filename, $rdata, $objs) = @_;
944 1168
945 sync_job { 1169 sync_job {
946 if (length $$rdata) { 1170 if (length $$rdata) {
1171 utf8::decode (my $decname = $filename);
947 warn sprintf "saving %s (%d,%d)\n", 1172 warn sprintf "saving %s (%d,%d)\n",
948 $filename, length $$rdata, scalar @$objs; 1173 $decname, length $$rdata, scalar @$objs;
949 1174
950 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1175 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
951 chmod SAVE_MODE, $fh; 1176 aio_chmod $fh, SAVE_MODE;
952 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1177 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
953 aio_fsync $fh if $cf::USE_FSYNC; 1178 aio_fsync $fh if $cf::USE_FSYNC;
954 close $fh; 1179 aio_close $fh;
955 1180
956 if (@$objs) { 1181 if (@$objs) {
957 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1182 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
958 chmod SAVE_MODE, $fh; 1183 aio_chmod $fh, SAVE_MODE;
959 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1184 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
960 aio_write $fh, 0, (length $data), $data, 0; 1185 aio_write $fh, 0, (length $data), $data, 0;
961 aio_fsync $fh if $cf::USE_FSYNC; 1186 aio_fsync $fh if $cf::USE_FSYNC;
962 close $fh; 1187 aio_close $fh;
963 aio_rename "$filename.pst~", "$filename.pst"; 1188 aio_rename "$filename.pst~", "$filename.pst";
964 } 1189 }
965 } else { 1190 } else {
966 aio_unlink "$filename.pst"; 1191 aio_unlink "$filename.pst";
967 } 1192 }
968 1193
969 aio_rename "$filename~", $filename; 1194 aio_rename "$filename~", $filename;
1195
1196 $filename =~ s%/[^/]+$%%;
1197 aio_pathsync $filename if $cf::USE_FSYNC;
970 } else { 1198 } else {
971 warn "FATAL: $filename~: $!\n"; 1199 warn "FATAL: $filename~: $!\n";
972 } 1200 }
973 } else { 1201 } else {
974 aio_unlink $filename; 1202 aio_unlink $filename;
975 aio_unlink "$filename.pst"; 1203 aio_unlink "$filename.pst";
976 } 1204 }
977 } 1205 };
978} 1206}
979 1207
980sub object_freezer_as_string { 1208sub object_freezer_as_string {
981 my ($rdata, $objs) = @_; 1209 my ($rdata, $objs) = @_;
982 1210
… …
994 or return; 1222 or return;
995 1223
996 unless (aio_stat "$filename.pst") { 1224 unless (aio_stat "$filename.pst") {
997 (aio_load "$filename.pst", $av) >= 0 1225 (aio_load "$filename.pst", $av) >= 0
998 or return; 1226 or return;
1227
999 $av = eval { (Storable::thaw $av)->{objs} }; 1228 my $st = eval { Coro::Storable::thaw $av };
1229 $av = $st->{objs};
1000 } 1230 }
1001 1231
1232 utf8::decode (my $decname = $filename);
1002 warn sprintf "loading %s (%d)\n", 1233 warn sprintf "loading %s (%d,%d)\n",
1003 $filename, length $data, scalar @{$av || []}; 1234 $decname, length $data, scalar @{$av || []};
1235
1004 return ($data, $av); 1236 ($data, $av)
1005} 1237}
1006 1238
1007=head2 COMMAND CALLBACKS 1239=head2 COMMAND CALLBACKS
1008 1240
1009=over 4 1241=over 4
… …
1029 push @{ $COMMAND{$name} }, [$caller, $cb]; 1261 push @{ $COMMAND{$name} }, [$caller, $cb];
1030} 1262}
1031 1263
1032=item cf::register_extcmd $name => \&callback($pl,$packet); 1264=item cf::register_extcmd $name => \&callback($pl,$packet);
1033 1265
1034Register a callback fro execution when the client sends an extcmd packet. 1266Register a callback for execution when the client sends an (synchronous)
1267extcmd packet. Ext commands will be processed in the order they are
1268received by the server, like other user commands. The first argument is
1269the logged-in player. Ext commands can only be processed after a player
1270has logged in successfully.
1035 1271
1036If the callback returns something, it is sent back as if reply was being 1272If the callback returns something, it is sent back as if reply was being
1037called. 1273called.
1038 1274
1275=item cf::register_exticmd $name => \&callback($ns,$packet);
1276
1277Register a callback for execution when the client sends an (asynchronous)
1278exticmd packet. Exti commands are processed by the server as soon as they
1279are received, i.e. out of order w.r.t. other commands. The first argument
1280is a client socket. Exti commands can be received anytime, even before
1281log-in.
1282
1283If the callback returns something, it is sent back as if reply was being
1284called.
1285
1039=cut 1286=cut
1040 1287
1041sub register_extcmd { 1288sub register_extcmd {
1042 my ($name, $cb) = @_; 1289 my ($name, $cb) = @_;
1043 1290
1044 $EXTCMD{$name} = $cb; 1291 $EXTCMD{$name} = $cb;
1045} 1292}
1293
1294sub register_exticmd {
1295 my ($name, $cb) = @_;
1296
1297 $EXTICMD{$name} = $cb;
1298}
1299
1300use File::Glob ();
1046 1301
1047cf::player->attach ( 1302cf::player->attach (
1048 on_command => sub { 1303 on_command => sub {
1049 my ($pl, $name, $params) = @_; 1304 my ($pl, $name, $params) = @_;
1050 1305
… …
1058 cf::override; 1313 cf::override;
1059 }, 1314 },
1060 on_extcmd => sub { 1315 on_extcmd => sub {
1061 my ($pl, $buf) = @_; 1316 my ($pl, $buf) = @_;
1062 1317
1063 my $msg = eval { from_json $buf }; 1318 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1064 1319
1065 if (ref $msg) { 1320 if (ref $msg) {
1321 my ($type, $reply, @payload) =
1322 "ARRAY" eq ref $msg
1323 ? @$msg
1324 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1325
1326 my @reply;
1327
1066 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1328 if (my $cb = $EXTCMD{$type}) {
1067 if (my %reply = $cb->($pl, $msg)) { 1329 @reply = $cb->($pl, @payload);
1068 $pl->ext_reply ($msg->{msgid}, %reply);
1069 }
1070 } 1330 }
1331
1332 $pl->ext_reply ($reply, @reply)
1333 if $reply;
1334
1071 } else { 1335 } else {
1072 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1336 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1073 } 1337 }
1074 1338
1075 cf::override; 1339 cf::override;
1076 }, 1340 },
1077); 1341);
1342
1343# "readahead" all extensions
1344sub cache_extensions {
1345 my $grp = IO::AIO::aio_group;
1346
1347 add $grp IO::AIO::aio_readdir $LIBDIR, sub {
1348 for (grep /\.ext$/, @{$_[0]}) {
1349 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1350 }
1351 };
1352
1353 $grp
1354}
1078 1355
1079sub load_extensions { 1356sub load_extensions {
1080 cf::sync_job { 1357 cf::sync_job {
1081 my %todo; 1358 my %todo;
1082 1359
… …
1102 1379
1103 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1380 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1104 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1381 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1105 1382
1106 $ext{source} = 1383 $ext{source} =
1107 "package $pkg; use strict; use utf8;\n" 1384 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1108 . "#line 1 \"$path\"\n{\n" 1385 . "#line 1 \"$path\"\n{\n"
1109 . $source 1386 . $source
1110 . "\n};\n1"; 1387 . "\n};\n1";
1111 1388
1112 $todo{$base} = \%ext; 1389 $todo{$base} = \%ext;
… …
1128 my $msg = $@ ? "$v->{path}: $@\n" 1405 my $msg = $@ ? "$v->{path}: $@\n"
1129 : "$v->{base}: extension inactive.\n"; 1406 : "$v->{base}: extension inactive.\n";
1130 1407
1131 if (exists $v->{meta}{mandatory}) { 1408 if (exists $v->{meta}{mandatory}) {
1132 warn $msg; 1409 warn $msg;
1133 warn "mandatory extension failed to load, exiting.\n"; 1410 cf::cleanup "mandatory extension failed to load, exiting.";
1134 exit 1;
1135 } 1411 }
1136 1412
1137 warn $msg; 1413 warn $msg;
1138 } 1414 }
1139 1415
… …
1153 1429
1154=back 1430=back
1155 1431
1156=head2 CORE EXTENSIONS 1432=head2 CORE EXTENSIONS
1157 1433
1158Functions and methods that extend core crossfire objects. 1434Functions and methods that extend core deliantra objects.
1159 1435
1160=cut 1436=cut
1161 1437
1162package cf::player; 1438package cf::player;
1163 1439
1164use Coro::AIO; 1440use Coro::AIO;
1165 1441
1166=head3 cf::player 1442=head3 cf::player
1167 1443
1168=over 4 1444=over 4
1445
1446=item cf::player::num_playing
1447
1448Returns the official number of playing players, as per the Crossfire metaserver rules.
1449
1450=cut
1451
1452sub num_playing {
1453 scalar grep
1454 $_->ob->map
1455 && !$_->hidden
1456 && !$_->ob->flag (cf::FLAG_WIZ),
1457 cf::player::list
1458}
1169 1459
1170=item cf::player::find $login 1460=item cf::player::find $login
1171 1461
1172Returns the given player object, loading it if necessary (might block). 1462Returns the given player object, loading it if necessary (might block).
1173 1463
… …
1192 1482
1193sub exists($) { 1483sub exists($) {
1194 my ($login) = @_; 1484 my ($login) = @_;
1195 1485
1196 $cf::PLAYER{$login} 1486 $cf::PLAYER{$login}
1197 or cf::sync_job { !aio_stat path $login } 1487 or !aio_stat path $login
1198} 1488}
1199 1489
1200sub find($) { 1490sub find($) {
1201 return $cf::PLAYER{$_[0]} || do { 1491 return $cf::PLAYER{$_[0]} || do {
1202 my $login = $_[0]; 1492 my $login = $_[0];
… …
1209 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1499 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1210 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1500 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1211 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1501 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1212 aio_unlink +(playerdir $login) . "/$login.pl"; 1502 aio_unlink +(playerdir $login) . "/$login.pl";
1213 1503
1214 my $pl = load_pl path $login 1504 my $f = new_from_file cf::object::thawer path $login
1215 or return; 1505 or return;
1506
1507 my $pl = cf::player::load_pl $f
1508 or return;
1509
1510 local $cf::PLAYER_LOADING{$login} = $pl;
1511 $f->resolve_delayed_derefs;
1216 $cf::PLAYER{$login} = $pl 1512 $cf::PLAYER{$login} = $pl
1217 } 1513 }
1218 } 1514 }
1219} 1515}
1220 1516
… …
1229 return if $pl->{deny_save}; 1525 return if $pl->{deny_save};
1230 1526
1231 aio_mkdir playerdir $pl, 0770; 1527 aio_mkdir playerdir $pl, 0770;
1232 $pl->{last_save} = $cf::RUNTIME; 1528 $pl->{last_save} = $cf::RUNTIME;
1233 1529
1530 cf::get_slot 0.01;
1531
1234 $pl->save_pl ($path); 1532 $pl->save_pl ($path);
1235 Coro::cede; 1533 cf::cede_to_tick;
1236} 1534}
1237 1535
1238sub new($) { 1536sub new($) {
1239 my ($login) = @_; 1537 my ($login) = @_;
1240 1538
… …
1246 $cf::PLAYER{$login} = $self; 1544 $cf::PLAYER{$login} = $self;
1247 1545
1248 $self 1546 $self
1249} 1547}
1250 1548
1549=item $player->send_msg ($channel, $msg, $color, [extra...])
1550
1551=cut
1552
1553sub send_msg {
1554 my $ns = shift->ns
1555 or return;
1556 $ns->send_msg (@_);
1557}
1558
1251=item $pl->quit_character 1559=item $pl->quit_character
1252 1560
1253Nukes the player without looking back. If logged in, the connection will 1561Nukes the player without looking back. If logged in, the connection will
1254be destroyed. May block for a long time. 1562be destroyed. May block for a long time.
1255 1563
… …
1259 my ($pl) = @_; 1567 my ($pl) = @_;
1260 1568
1261 my $name = $pl->ob->name; 1569 my $name = $pl->ob->name;
1262 1570
1263 $pl->{deny_save} = 1; 1571 $pl->{deny_save} = 1;
1264 $pl->password ("*"); # this should lock out the player until we nuked the dir 1572 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1265 1573
1266 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1574 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1267 $pl->deactivate; 1575 $pl->deactivate;
1576 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1577 $pl->ob->check_score;
1268 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1578 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1269 $pl->ns->destroy if $pl->ns; 1579 $pl->ns->destroy if $pl->ns;
1270 1580
1271 my $path = playerdir $pl; 1581 my $path = playerdir $pl;
1272 my $temp = "$path~$cf::RUNTIME~deleting~"; 1582 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1308 or return []; 1618 or return [];
1309 1619
1310 my @logins; 1620 my @logins;
1311 1621
1312 for my $login (@$dirs) { 1622 for my $login (@$dirs) {
1623 my $path = path $login;
1624
1625 # a .pst is a dead give-away for a valid player
1626 # if no pst file found, open and chekc for blocked users
1627 if (aio_stat "$path.pst") {
1313 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1628 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1314 aio_read $fh, 0, 512, my $buf, 0 or next; 1629 aio_read $fh, 0, 512, my $buf, 0 or next;
1315 $buf !~ /^password -------------$/m or next; # official not-valid tag 1630 $buf !~ /^password -------------$/m or next; # official not-valid tag
1631 }
1316 1632
1317 utf8::decode $login; 1633 utf8::decode $login;
1318 push @logins, $login; 1634 push @logins, $login;
1319 } 1635 }
1320 1636
… …
1347 } 1663 }
1348 1664
1349 \@paths 1665 \@paths
1350} 1666}
1351 1667
1668=item $protocol_xml = $player->expand_cfpod ($cfpod)
1669
1670Expand deliantra pod fragments into protocol xml.
1671
1352=item $player->ext_reply ($msgid, %msg) 1672=item $player->ext_reply ($msgid, @msg)
1353 1673
1354Sends an ext reply to the player. 1674Sends an ext reply to the player.
1355 1675
1356=cut 1676=cut
1357 1677
1358sub ext_reply($$%) { 1678sub ext_reply($$@) {
1359 my ($self, $id, %msg) = @_; 1679 my ($self, $id, @msg) = @_;
1360 1680
1361 $msg{msgid} = $id; 1681 $self->ns->ext_reply ($id, @msg)
1362
1363 $self->send ("ext " . cf::to_json \%msg);
1364} 1682}
1365 1683
1366=item $player->ext_event ($type, %msg) 1684=item $player->ext_msg ($type, @msg)
1367 1685
1368Sends an ext event to the client. 1686Sends an ext event to the client.
1369 1687
1370=cut 1688=cut
1371 1689
1372sub ext_event($$%) { 1690sub ext_msg($$@) {
1373 my ($self, $type, %msg) = @_; 1691 my ($self, $type, @msg) = @_;
1374 1692
1375 $self->ns->ext_event ($type, %msg); 1693 $self->ns->ext_msg ($type, @msg);
1376} 1694}
1377 1695
1378=head3 cf::region 1696=head3 cf::region
1379 1697
1380=over 4 1698=over 4
… …
1393 my ($path) = @_; 1711 my ($path) = @_;
1394 1712
1395 my ($match, $specificity); 1713 my ($match, $specificity);
1396 1714
1397 for my $region (list) { 1715 for my $region (list) {
1398 if ($region->match && $path =~ $region->match) { 1716 if ($region->{match} && $path =~ $region->{match}) {
1399 ($match, $specificity) = ($region, $region->specificity) 1717 ($match, $specificity) = ($region, $region->specificity)
1400 if $region->specificity > $specificity; 1718 if $region->specificity > $specificity;
1401 } 1719 }
1402 } 1720 }
1403 1721
… …
1424our $MAX_RESET = 3600; 1742our $MAX_RESET = 3600;
1425our $DEFAULT_RESET = 3000; 1743our $DEFAULT_RESET = 3000;
1426 1744
1427sub generate_random_map { 1745sub generate_random_map {
1428 my ($self, $rmp) = @_; 1746 my ($self, $rmp) = @_;
1747
1748 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1749
1429 # mit "rum" bekleckern, nicht 1750 # mit "rum" bekleckern, nicht
1430 $self->_create_random_map ( 1751 $self->_create_random_map (
1431 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1752 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1432 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1753 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1433 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1754 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1523 $self->init; # pass $1 etc. 1844 $self->init; # pass $1 etc.
1524 return $self; 1845 return $self;
1525 } 1846 }
1526 } 1847 }
1527 1848
1528 Carp::carp "unable to resolve path '$path' (base '$base')."; 1849 Carp::cluck "unable to resolve path '$path' (base '$base').";
1529 () 1850 ()
1530} 1851}
1531 1852
1532sub init { 1853sub init {
1533 my ($self) = @_; 1854 my ($self) = @_;
… …
1555 1876
1556# the temporary/swap location 1877# the temporary/swap location
1557sub save_path { 1878sub save_path {
1558 my ($self) = @_; 1879 my ($self) = @_;
1559 1880
1560 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1881 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1561 "$TMPDIR/$path.map" 1882 "$TMPDIR/$path.map"
1562} 1883}
1563 1884
1564# the unique path, undef == no special unique path 1885# the unique path, undef == no special unique path
1565sub uniq_path { 1886sub uniq_path {
1566 my ($self) = @_; 1887 my ($self) = @_;
1567 1888
1568 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1889 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1569 "$UNIQUEDIR/$path" 1890 "$UNIQUEDIR/$path"
1570} 1891}
1571 1892
1572# and all this just because we cannot iterate over 1893# and all this just because we cannot iterate over
1573# all maps in C++... 1894# all maps in C++...
… …
1596 1917
1597sub load_header_from($) { 1918sub load_header_from($) {
1598 my ($self, $path) = @_; 1919 my ($self, $path) = @_;
1599 1920
1600 utf8::encode $path; 1921 utf8::encode $path;
1601 #aio_open $path, O_RDONLY, 0 1922 my $f = new_from_file cf::object::thawer $path
1602 # or return;
1603
1604 $self->_load_header ($path)
1605 or return; 1923 or return;
1924
1925 $self->_load_header ($f)
1926 or return;
1927
1928 local $MAP_LOADING{$self->{path}} = $self;
1929 $f->resolve_delayed_derefs;
1606 1930
1607 $self->{load_path} = $path; 1931 $self->{load_path} = $path;
1608 1932
1609 1 1933 1
1610} 1934}
… …
1664sub find { 1988sub find {
1665 my ($path, $origin) = @_; 1989 my ($path, $origin) = @_;
1666 1990
1667 $path = normalise $path, $origin && $origin->path; 1991 $path = normalise $path, $origin && $origin->path;
1668 1992
1993 cf::lock_wait "map_data:$path";#d#remove
1669 cf::lock_wait "map_find:$path"; 1994 cf::lock_wait "map_find:$path";
1670 1995
1671 $cf::MAP{$path} || do { 1996 $cf::MAP{$path} || do {
1997 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1672 my $guard = cf::lock_acquire "map_find:$path"; 1998 my $guard2 = cf::lock_acquire "map_find:$path";
1999
1673 my $map = new_from_path cf::map $path 2000 my $map = new_from_path cf::map $path
1674 or return; 2001 or return;
1675 2002
1676 $map->{last_save} = $cf::RUNTIME; 2003 $map->{last_save} = $cf::RUNTIME;
1677 2004
… …
1679 or return; 2006 or return;
1680 2007
1681 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2008 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1682 # doing this can freeze the server in a sync job, obviously 2009 # doing this can freeze the server in a sync job, obviously
1683 #$cf::WAIT_FOR_TICK->wait; 2010 #$cf::WAIT_FOR_TICK->wait;
2011 undef $guard2;
2012 undef $guard1;
1684 $map->reset; 2013 $map->reset;
1685 undef $guard;
1686 return find $path; 2014 return find $path;
1687 } 2015 }
1688 2016
1689 $cf::MAP{$path} = $map 2017 $cf::MAP{$path} = $map
1690 } 2018 }
… …
1699 local $self->{deny_reset} = 1; # loading can take a long time 2027 local $self->{deny_reset} = 1; # loading can take a long time
1700 2028
1701 my $path = $self->{path}; 2029 my $path = $self->{path};
1702 2030
1703 { 2031 {
1704 my $guard = cf::lock_acquire "map_load:$path"; 2032 my $guard = cf::lock_acquire "map_data:$path";
1705 2033
2034 return unless $self->valid;
1706 return if $self->in_memory != cf::MAP_SWAPPED; 2035 return unless $self->in_memory == cf::MAP_SWAPPED;
1707 2036
1708 $self->in_memory (cf::MAP_LOADING); 2037 $self->in_memory (cf::MAP_LOADING);
1709 2038
1710 $self->alloc; 2039 $self->alloc;
1711 2040
1712 $self->pre_load; 2041 $self->pre_load;
1713 Coro::cede; 2042 cf::cede_to_tick;
1714 2043
2044 my $f = new_from_file cf::object::thawer $self->{load_path};
2045 $f->skip_block;
1715 $self->_load_objects ($self->{load_path}, 1) 2046 $self->_load_objects ($f)
1716 or return; 2047 or return;
1717 2048
1718 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2049 $self->post_load_original
1719 if delete $self->{load_original}; 2050 if delete $self->{load_original};
1720 2051
1721 if (my $uniq = $self->uniq_path) { 2052 if (my $uniq = $self->uniq_path) {
1722 utf8::encode $uniq; 2053 utf8::encode $uniq;
1723 if (aio_open $uniq, O_RDONLY, 0) { 2054 unless (aio_stat $uniq) {
2055 if (my $f = new_from_file cf::object::thawer $uniq) {
1724 $self->clear_unique_items; 2056 $self->clear_unique_items;
1725 $self->_load_objects ($uniq, 0); 2057 $self->_load_objects ($f);
2058 $f->resolve_delayed_derefs;
2059 }
1726 } 2060 }
1727 } 2061 }
1728 2062
1729 Coro::cede; 2063 $f->resolve_delayed_derefs;
2064
2065 cf::cede_to_tick;
1730 # now do the right thing for maps 2066 # now do the right thing for maps
1731 $self->link_multipart_objects; 2067 $self->link_multipart_objects;
1732 $self->difficulty ($self->estimate_difficulty) 2068 $self->difficulty ($self->estimate_difficulty)
1733 unless $self->difficulty; 2069 unless $self->difficulty;
1734 Coro::cede; 2070 cf::cede_to_tick;
1735 2071
1736 unless ($self->{deny_activate}) { 2072 unless ($self->{deny_activate}) {
1737 $self->decay_objects; 2073 $self->decay_objects;
1738 $self->fix_auto_apply; 2074 $self->fix_auto_apply;
1739 $self->update_buttons; 2075 $self->update_buttons;
1740 Coro::cede; 2076 cf::cede_to_tick;
1741 $self->set_darkness_map; 2077 $self->set_darkness_map;
1742 Coro::cede; 2078 cf::cede_to_tick;
1743 $self->activate; 2079 $self->activate;
1744 } 2080 }
1745 2081
2082 $self->{last_save} = $cf::RUNTIME;
2083 $self->last_access ($cf::RUNTIME);
2084
1746 $self->in_memory (cf::MAP_IN_MEMORY); 2085 $self->in_memory (cf::MAP_ACTIVE);
1747 } 2086 }
1748 2087
1749 $self->post_load; 2088 $self->post_load;
1750} 2089}
1751 2090
… …
1760 2099
1761 $self 2100 $self
1762} 2101}
1763 2102
1764# find and load all maps in the 3x3 area around a map 2103# find and load all maps in the 3x3 area around a map
1765sub load_diag { 2104sub load_neighbours {
1766 my ($map) = @_; 2105 my ($map) = @_;
1767 2106
1768 my @diag; # diagonal neighbours 2107 my @neigh; # diagonal neighbours
1769 2108
1770 for (0 .. 3) { 2109 for (0 .. 3) {
1771 my $neigh = $map->tile_path ($_) 2110 my $neigh = $map->tile_path ($_)
1772 or next; 2111 or next;
1773 $neigh = find $neigh, $map 2112 $neigh = find $neigh, $map
1774 or next; 2113 or next;
1775 $neigh->load; 2114 $neigh->load;
1776 2115
2116 push @neigh,
1777 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2117 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1778 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2118 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1779 } 2119 }
1780 2120
1781 for (@diag) { 2121 for (grep defined $_->[0], @neigh) {
2122 my ($path, $origin) = @$_;
1782 my $neigh = find @$_ 2123 my $neigh = find $path, $origin
1783 or next; 2124 or next;
1784 $neigh->load; 2125 $neigh->load;
1785 } 2126 }
1786} 2127}
1787 2128
… …
1792} 2133}
1793 2134
1794sub do_load_sync { 2135sub do_load_sync {
1795 my ($map) = @_; 2136 my ($map) = @_;
1796 2137
2138 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2139 if $Coro::current == $Coro::main;
2140
1797 cf::sync_job { $map->load }; 2141 cf::sync_job { $map->load };
1798} 2142}
1799 2143
1800our %MAP_PREFETCH; 2144our %MAP_PREFETCH;
1801our $MAP_PREFETCHER = undef; 2145our $MAP_PREFETCHER = undef;
1802 2146
1803sub find_async { 2147sub find_async {
1804 my ($path, $origin) = @_; 2148 my ($path, $origin, $load) = @_;
1805 2149
1806 $path = normalise $path, $origin && $origin->{path}; 2150 $path = normalise $path, $origin && $origin->{path};
1807 2151
1808 if (my $map = $cf::MAP{$path}) { 2152 if (my $map = $cf::MAP{$path}) {
1809 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2153 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1810 } 2154 }
1811 2155
1812 undef $MAP_PREFETCH{$path}; 2156 $MAP_PREFETCH{$path} |= $load;
2157
1813 $MAP_PREFETCHER ||= cf::async { 2158 $MAP_PREFETCHER ||= cf::async {
2159 $Coro::current->{desc} = "map prefetcher";
2160
1814 while (%MAP_PREFETCH) { 2161 while (%MAP_PREFETCH) {
1815 for my $path (keys %MAP_PREFETCH) { 2162 while (my ($k, $v) = each %MAP_PREFETCH) {
1816 my $map = find $path 2163 if (my $map = find $k) {
1817 or next;
1818 $map->load; 2164 $map->load if $v;
2165 }
1819 2166
1820 delete $MAP_PREFETCH{$path}; 2167 delete $MAP_PREFETCH{$k};
1821 } 2168 }
1822 } 2169 }
1823 undef $MAP_PREFETCHER; 2170 undef $MAP_PREFETCHER;
1824 }; 2171 };
1825 $MAP_PREFETCHER->prio (6); 2172 $MAP_PREFETCHER->prio (6);
… …
1828} 2175}
1829 2176
1830sub save { 2177sub save {
1831 my ($self) = @_; 2178 my ($self) = @_;
1832 2179
1833 my $lock = cf::lock_acquire "map_data:" . $self->path; 2180 my $lock = cf::lock_acquire "map_data:$self->{path}";
1834 2181
1835 $self->{last_save} = $cf::RUNTIME; 2182 $self->{last_save} = $cf::RUNTIME;
1836 2183
1837 return unless $self->dirty; 2184 return unless $self->dirty;
1838 2185
… …
1844 return if $self->{deny_save}; 2191 return if $self->{deny_save};
1845 2192
1846 local $self->{last_access} = $self->last_access;#d# 2193 local $self->{last_access} = $self->last_access;#d#
1847 2194
1848 cf::async { 2195 cf::async {
2196 $Coro::current->{desc} = "map player save";
1849 $_->contr->save for $self->players; 2197 $_->contr->save for $self->players;
1850 }; 2198 };
2199
2200 cf::get_slot 0.02;
1851 2201
1852 if ($uniq) { 2202 if ($uniq) {
1853 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2203 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1854 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2204 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1855 } else { 2205 } else {
… …
1861 my ($self) = @_; 2211 my ($self) = @_;
1862 2212
1863 # save first because save cedes 2213 # save first because save cedes
1864 $self->save; 2214 $self->save;
1865 2215
1866 my $lock = cf::lock_acquire "map_data:" . $self->path; 2216 my $lock = cf::lock_acquire "map_data:$self->{path}";
1867 2217
1868 return if $self->players; 2218 return if $self->players;
1869 return if $self->in_memory != cf::MAP_IN_MEMORY; 2219 return if $self->in_memory != cf::MAP_ACTIVE;
1870 return if $self->{deny_save}; 2220 return if $self->{deny_save};
1871 2221
2222 $self->in_memory (cf::MAP_SWAPPED);
2223
2224 $self->deactivate;
2225 $_->clear_links_to ($self) for values %cf::MAP;
1872 $self->clear; 2226 $self->clear;
1873 $self->in_memory (cf::MAP_SWAPPED);
1874} 2227}
1875 2228
1876sub reset_at { 2229sub reset_at {
1877 my ($self) = @_; 2230 my ($self) = @_;
1878 2231
… …
1910 if $uniq; 2263 if $uniq;
1911 } 2264 }
1912 2265
1913 delete $cf::MAP{$self->path}; 2266 delete $cf::MAP{$self->path};
1914 2267
2268 $self->deactivate;
2269 $_->clear_links_to ($self) for values %cf::MAP;
1915 $self->clear; 2270 $self->clear;
1916
1917 $_->clear_links_to ($self) for values %cf::MAP;
1918 2271
1919 $self->unlink_save; 2272 $self->unlink_save;
1920 $self->destroy; 2273 $self->destroy;
1921} 2274}
1922 2275
1923my $nuke_counter = "aaaa"; 2276my $nuke_counter = "aaaa";
1924 2277
1925sub nuke { 2278sub nuke {
1926 my ($self) = @_; 2279 my ($self) = @_;
1927 2280
2281 {
2282 my $lock = cf::lock_acquire "map_data:$self->{path}";
2283
1928 delete $cf::MAP{$self->path}; 2284 delete $cf::MAP{$self->path};
1929 2285
1930 $self->unlink_save; 2286 $self->unlink_save;
1931 2287
1932 bless $self, "cf::map"; 2288 bless $self, "cf::map";
1933 delete $self->{deny_reset}; 2289 delete $self->{deny_reset};
1934 $self->{deny_save} = 1; 2290 $self->{deny_save} = 1;
1935 $self->reset_timeout (1); 2291 $self->reset_timeout (1);
1936 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2292 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1937 2293
1938 $cf::MAP{$self->path} = $self; 2294 $cf::MAP{$self->path} = $self;
2295 }
1939 2296
1940 $self->reset; # polite request, might not happen 2297 $self->reset; # polite request, might not happen
1941} 2298}
1942 2299
1943=item $maps = cf::map::tmp_maps 2300=item $maps = cf::map::tmp_maps
… …
1985 2342
1986sub unique_maps() { 2343sub unique_maps() {
1987 [ 2344 [
1988 map { 2345 map {
1989 utf8::decode $_; 2346 utf8::decode $_;
1990 /\.map$/ 2347 s/\.map$//; # TODO future compatibility hack
2348 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2349 ? ()
1991 ? normalise $_ 2350 : normalise $_
1992 : ()
1993 } @{ aio_readdir $UNIQUEDIR or [] } 2351 } @{ aio_readdir $UNIQUEDIR or [] }
1994 ] 2352 ]
1995} 2353}
1996 2354
1997package cf;
1998
1999=back 2355=back
2000 2356
2001=head3 cf::object 2357=head3 cf::object
2002 2358
2003=cut 2359=cut
… …
2006 2362
2007=over 4 2363=over 4
2008 2364
2009=item $ob->inv_recursive 2365=item $ob->inv_recursive
2010 2366
2011Returns the inventory of the object _and_ their inventories, recursively. 2367Returns the inventory of the object I<and> their inventories, recursively,
2368but I<not> the object itself.
2012 2369
2013=cut 2370=cut
2014 2371
2015sub inv_recursive_; 2372sub inv_recursive_;
2016sub inv_recursive_ { 2373sub inv_recursive_ {
… …
2019 2376
2020sub inv_recursive { 2377sub inv_recursive {
2021 inv_recursive_ inv $_[0] 2378 inv_recursive_ inv $_[0]
2022} 2379}
2023 2380
2381=item $ref = $ob->ref
2382
2383Creates and returns a persistent reference to an object that can be stored as a string.
2384
2385=item $ob = cf::object::deref ($refstring)
2386
2387returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2388even if the object actually exists. May block.
2389
2390=cut
2391
2392sub deref {
2393 my ($ref) = @_;
2394
2395 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2396 my ($uuid, $name) = ($1, $2);
2397 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2398 or return;
2399 $pl->ob->uuid eq $uuid
2400 or return;
2401
2402 $pl->ob
2403 } else {
2404 warn "$ref: cannot resolve object reference\n";
2405 undef
2406 }
2407}
2408
2024package cf; 2409package cf;
2025 2410
2026=back 2411=back
2027 2412
2028=head3 cf::object::player 2413=head3 cf::object::player
… …
2034Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2419Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2035can be C<undef>. Does the right thing when the player is currently in a 2420can be C<undef>. Does the right thing when the player is currently in a
2036dialogue with the given NPC character. 2421dialogue with the given NPC character.
2037 2422
2038=cut 2423=cut
2424
2425our $SAY_CHANNEL = {
2426 id => "say",
2427 title => "Map",
2428 reply => "say ",
2429 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2430};
2431
2432our $CHAT_CHANNEL = {
2433 id => "chat",
2434 title => "Chat",
2435 reply => "chat ",
2436 tooltip => "Player chat and shouts, global to the server.",
2437};
2039 2438
2040# rough implementation of a future "reply" method that works 2439# rough implementation of a future "reply" method that works
2041# with dialog boxes. 2440# with dialog boxes.
2042#TODO: the first argument must go, split into a $npc->reply_to ( method 2441#TODO: the first argument must go, split into a $npc->reply_to ( method
2043sub cf::object::player::reply($$$;$) { 2442sub cf::object::player::reply($$$;$) {
… …
2050 2449
2051 } else { 2450 } else {
2052 my $pl = $self->contr; 2451 my $pl = $self->contr;
2053 2452
2054 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) { 2453 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2055 my $diag = $pl->{npc_dialog}; 2454 my $dialog = $pl->{npc_dialog};
2056 $diag->{pl}->ext_reply ( 2455 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2057 $diag->{id}, msgtype => "reply", msg => $msg, add_topics => []
2058 );
2059 2456
2060 } else { 2457 } else {
2061 $msg = $npc->name . " says: $msg" if $npc; 2458 $msg = $npc->name . " says: $msg" if $npc;
2062 $self->message ($msg, $flags); 2459 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2063 } 2460 }
2064 } 2461 }
2462}
2463
2464=item $object->send_msg ($channel, $msg, $color, [extra...])
2465
2466=cut
2467
2468sub cf::object::send_msg {
2469 my $pl = shift->contr
2470 or return;
2471 $pl->send_msg (@_);
2065} 2472}
2066 2473
2067=item $player_object->may ("access") 2474=item $player_object->may ("access")
2068 2475
2069Returns wether the given player is authorized to access resource "access" 2476Returns wether the given player is authorized to access resource "access"
… …
2082 2489
2083=item $player_object->enter_link 2490=item $player_object->enter_link
2084 2491
2085Freezes the player and moves him/her to a special map (C<{link}>). 2492Freezes the player and moves him/her to a special map (C<{link}>).
2086 2493
2087The player should be reasonably safe there for short amounts of time. You 2494The player should be reasonably safe there for short amounts of time (e.g.
2088I<MUST> call C<leave_link> as soon as possible, though. 2495for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2496though, as the palyer cannot control the character while it is on the link
2497map.
2089 2498
2090Will never block. 2499Will never block.
2091 2500
2092=item $player_object->leave_link ($map, $x, $y) 2501=item $player_object->leave_link ($map, $x, $y)
2093 2502
… …
2148 # use -1 or undef as default coordinates, not 0, 0 2557 # use -1 or undef as default coordinates, not 0, 0
2149 ($x, $y) = ($map->enter_x, $map->enter_y) 2558 ($x, $y) = ($map->enter_x, $map->enter_y)
2150 if $x <=0 && $y <= 0; 2559 if $x <=0 && $y <= 0;
2151 2560
2152 $map->load; 2561 $map->load;
2153 $map->load_diag; 2562 $map->load_neighbours;
2154 2563
2155 return unless $self->contr->active; 2564 return unless $self->contr->active;
2565 $self->flag (cf::FLAG_DEBUG, 0);#d# temp
2156 $self->activate_recursive; 2566 $self->activate_recursive;
2157 2567
2158 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2568 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2159 $self->enter_map ($map, $x, $y); 2569 $self->enter_map ($map, $x, $y);
2160} 2570}
2161 2571
2162=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2572=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2163 2573
2164Moves the player to the given map-path and coordinates by first freezing 2574Moves the player to the given map-path and coordinates by first freezing
2165her, loading and preparing them map, calling the provided $check callback 2575her, loading and preparing them map, calling the provided $check callback
2166that has to return the map if sucecssful, and then unfreezes the player on 2576that has to return the map if sucecssful, and then unfreezes the player on
2167the new (success) or old (failed) map position. 2577the new (success) or old (failed) map position. In either case, $done will
2578be called at the end of this process.
2579
2580Note that $check will be called with a potentially non-loaded map, so if
2581it needs a loaded map it has to call C<< ->load >>.
2168 2582
2169=cut 2583=cut
2170 2584
2171our $GOTOGEN; 2585our $GOTOGEN;
2172 2586
2173sub cf::object::player::goto { 2587sub cf::object::player::goto {
2174 my ($self, $path, $x, $y, $check) = @_; 2588 my ($self, $path, $x, $y, $check, $done) = @_;
2175 2589
2176 # do generation counting so two concurrent goto's will be executed in-order 2590 # do generation counting so two concurrent goto's will be executed in-order
2177 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2591 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2178 2592
2179 $self->enter_link; 2593 $self->enter_link;
2180 2594
2181 (async { 2595 (async {
2596 $Coro::current->{desc} = "player::goto $path $x $y";
2597
2598 # *tag paths override both path and x|y
2599 if ($path =~ /^\*(.*)$/) {
2600 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2601 my $ob = $obs[rand @obs];
2602
2603 # see if we actually can go there
2604 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2605 $ob = $obs[rand @obs];
2606 } else {
2607 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2608 }
2609 # else put us there anyways for now #d#
2610
2611 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2612 } else {
2613 ($path, $x, $y) = (undef, undef, undef);
2614 }
2615 }
2616
2182 my $map = eval { 2617 my $map = eval {
2183 my $map = cf::map::find $path; 2618 my $map = defined $path ? cf::map::find $path : undef;
2184 2619
2185 if ($map) { 2620 if ($map) {
2186 $map = $map->customise_for ($self); 2621 $map = $map->customise_for ($self);
2187 $map = $check->($map) if $check && $map; 2622 $map = $check->($map) if $check && $map;
2188 } else { 2623 } else {
2189 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2624 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2190 } 2625 }
2191 2626
2192 $map 2627 $map
2193 }; 2628 };
2194 2629
… …
2199 2634
2200 if ($gen == $self->{_goto_generation}) { 2635 if ($gen == $self->{_goto_generation}) {
2201 delete $self->{_goto_generation}; 2636 delete $self->{_goto_generation};
2202 $self->leave_link ($map, $x, $y); 2637 $self->leave_link ($map, $x, $y);
2203 } 2638 }
2639
2640 $done->() if $done;
2204 })->prio (1); 2641 })->prio (1);
2205} 2642}
2206 2643
2207=item $player_object->enter_exit ($exit_object) 2644=item $player_object->enter_exit ($exit_object)
2208 2645
… …
2228} 2665}
2229 2666
2230sub prepare_random_map { 2667sub prepare_random_map {
2231 my ($exit) = @_; 2668 my ($exit) = @_;
2232 2669
2233 my $guard = cf::lock_acquire "exit_prepare:$exit";
2234
2235 # all this does is basically replace the /! path by 2670 # all this does is basically replace the /! path by
2236 # a new random map path (?random/...) with a seed 2671 # a new random map path (?random/...) with a seed
2237 # that depends on the exit object 2672 # that depends on the exit object
2238 2673
2239 my $rmp = parse_random_map_params $exit->msg; 2674 my $rmp = parse_random_map_params $exit->msg;
… …
2241 if ($exit->map) { 2676 if ($exit->map) {
2242 $rmp->{region} = $exit->region->name; 2677 $rmp->{region} = $exit->region->name;
2243 $rmp->{origin_map} = $exit->map->path; 2678 $rmp->{origin_map} = $exit->map->path;
2244 $rmp->{origin_x} = $exit->x; 2679 $rmp->{origin_x} = $exit->x;
2245 $rmp->{origin_y} = $exit->y; 2680 $rmp->{origin_y} = $exit->y;
2681
2682 $exit->map->touch;
2246 } 2683 }
2247 2684
2248 $rmp->{random_seed} ||= $exit->random_seed; 2685 $rmp->{random_seed} ||= $exit->random_seed;
2249 2686
2250 my $data = cf::to_json $rmp; 2687 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2251 my $md5 = Digest::MD5::md5_hex $data; 2688 my $md5 = Digest::MD5::md5_hex $data;
2252 my $meta = "$RANDOMDIR/$md5.meta"; 2689 my $meta = "$RANDOMDIR/$md5.meta";
2253 2690
2254 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2691 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2255 aio_write $fh, 0, (length $data), $data, 0; 2692 aio_write $fh, 0, (length $data), $data, 0;
2256 undef $fh; 2693 undef $fh;
2257 aio_rename "$meta~", $meta; 2694 aio_rename "$meta~", $meta;
2258 2695
2696 my $slaying = "?random/$md5";
2697
2698 if ($exit->valid) {
2259 $exit->slaying ("?random/$md5"); 2699 $exit->slaying ("?random/$md5");
2260 $exit->msg (undef); 2700 $exit->msg (undef);
2701 }
2261 } 2702 }
2262} 2703}
2263 2704
2264sub cf::object::player::enter_exit { 2705sub cf::object::player::enter_exit {
2265 my ($self, $exit) = @_; 2706 my ($self, $exit) = @_;
2266 2707
2267 return unless $self->type == cf::PLAYER; 2708 return unless $self->type == cf::PLAYER;
2268 2709
2269 if ($exit->slaying eq "/!") {
2270 #TODO: this should de-fi-ni-te-ly not be a sync-job
2271 # the problem is that $exit might not survive long enough
2272 # so it needs to be done right now, right here
2273 cf::sync_job { prepare_random_map $exit };
2274 }
2275
2276 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2277 my $hp = $exit->stats->hp;
2278 my $sp = $exit->stats->sp;
2279
2280 $self->enter_link; 2710 $self->enter_link;
2281 2711
2282 (async { 2712 (async {
2283 $self->deactivate_recursive; # just to be sure 2713 $Coro::current->{desc} = "enter_exit";
2714
2284 unless (eval { 2715 unless (eval {
2716 $self->deactivate_recursive; # just to be sure
2717
2718 # random map handling
2719 {
2720 my $guard = cf::lock_acquire "exit_prepare:$exit";
2721
2722 prepare_random_map $exit
2723 if $exit->slaying eq "/!";
2724 }
2725
2726 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2727 my $x = $exit->stats->hp;
2728 my $y = $exit->stats->sp;
2729
2285 $self->goto ($slaying, $hp, $sp); 2730 $self->goto ($map, $x, $y);
2286 2731
2732 # if exit is damned, update players death & WoR home-position
2733 $self->contr->savebed ($map, $x, $y)
2734 if $exit->flag (cf::FLAG_DAMNED);
2735
2287 1; 2736 1
2288 }) { 2737 }) {
2289 $self->message ("Something went wrong deep within the crossfire server. " 2738 $self->message ("Something went wrong deep within the deliantra server. "
2290 . "I'll try to bring you back to the map you were before. " 2739 . "I'll try to bring you back to the map you were before. "
2291 . "Please report this to the dungeon master!", 2740 . "Please report this to the dungeon master!",
2292 cf::NDI_UNIQUE | cf::NDI_RED); 2741 cf::NDI_UNIQUE | cf::NDI_RED);
2293 2742
2294 warn "ERROR in enter_exit: $@"; 2743 warn "ERROR in enter_exit: $@";
… …
2313 2762
2314 utf8::encode $text; 2763 utf8::encode $text;
2315 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2764 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2316} 2765}
2317 2766
2767=item $client->send_msg ($channel, $msg, $color, [extra...])
2768
2769Send a drawinfo or msg packet to the client, formatting the msg for the
2770client if neccessary. C<$type> should be a string identifying the type of
2771the message, with C<log> being the default. If C<$color> is negative, suppress
2772the message unless the client supports the msg packet.
2773
2774=cut
2775
2776# non-persistent channels (usually the info channel)
2777our %CHANNEL = (
2778 "c/identify" => {
2779 id => "infobox",
2780 title => "Identify",
2781 reply => undef,
2782 tooltip => "Items recently identified",
2783 },
2784 "c/examine" => {
2785 id => "infobox",
2786 title => "Examine",
2787 reply => undef,
2788 tooltip => "Signs and other items you examined",
2789 },
2790 "c/book" => {
2791 id => "infobox",
2792 title => "Book",
2793 reply => undef,
2794 tooltip => "The contents of a note or book",
2795 },
2796 "c/lookat" => {
2797 id => "infobox",
2798 title => "Look",
2799 reply => undef,
2800 tooltip => "What you saw there",
2801 },
2802 "c/who" => {
2803 id => "infobox",
2804 title => "Players",
2805 reply => undef,
2806 tooltip => "Shows players who are currently online",
2807 },
2808 "c/body" => {
2809 id => "infobox",
2810 title => "Body Parts",
2811 reply => undef,
2812 tooltip => "Shows which body parts you posess and are available",
2813 },
2814 "c/skills" => {
2815 id => "infobox",
2816 title => "Skills",
2817 reply => undef,
2818 tooltip => "Shows your experience per skill and item power",
2819 },
2820 "c/uptime" => {
2821 id => "infobox",
2822 title => "Uptime",
2823 reply => undef,
2824 tooltip => "How long the server has been running since last restart",
2825 },
2826 "c/mapinfo" => {
2827 id => "infobox",
2828 title => "Map Info",
2829 reply => undef,
2830 tooltip => "Information related to the maps",
2831 },
2832 "c/party" => {
2833 id => "party",
2834 title => "Party",
2835 reply => "gsay ",
2836 tooltip => "Messages and chat related to your party",
2837 },
2838);
2839
2840sub cf::client::send_msg {
2841 my ($self, $channel, $msg, $color, @extra) = @_;
2842
2843 $msg = $self->pl->expand_cfpod ($msg)
2844 unless $color & cf::NDI_VERBATIM;
2845
2846 $color &= cf::NDI_CLIENT_MASK; # just in case...
2847
2848 # check predefined channels, for the benefit of C
2849 if ($CHANNEL{$channel}) {
2850 $channel = $CHANNEL{$channel};
2851
2852 $self->ext_msg (channel_info => $channel)
2853 if $self->can_msg;
2854
2855 $channel = $channel->{id};
2856
2857 } elsif (ref $channel) {
2858 # send meta info to client, if not yet sent
2859 unless (exists $self->{channel}{$channel->{id}}) {
2860 $self->{channel}{$channel->{id}} = $channel;
2861 $self->ext_msg (channel_info => $channel)
2862 if $self->can_msg;
2863 }
2864
2865 $channel = $channel->{id};
2866 }
2867
2868 return unless @extra || length $msg;
2869
2870 if ($self->can_msg) {
2871 # default colour, mask it out
2872 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2873 if $color & cf::NDI_DEF;
2874
2875 my $pkt = "msg "
2876 . $self->{json_coder}->encode (
2877 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2878 );
2879
2880 # try lzf for large packets
2881 $pkt = "lzf " . Compress::LZF::compress $pkt
2882 if 1024 <= length $pkt and $self->{can_lzf};
2883
2884 # split very large packets
2885 if (8192 < length $pkt and $self->{can_lzf}) {
2886 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2887 $pkt = "frag";
2888 }
2889
2890 $self->send_packet ($pkt);
2891 } else {
2892 if ($color >= 0) {
2893 # replace some tags by gcfclient-compatible ones
2894 for ($msg) {
2895 1 while
2896 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2897 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2898 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2899 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2900 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2901 }
2902
2903 $color &= cf::NDI_COLOR_MASK;
2904
2905 utf8::encode $msg;
2906
2907 if (0 && $msg =~ /\[/) {
2908 # COMMAND/INFO
2909 $self->send_packet ("drawextinfo $color 10 8 $msg")
2910 } else {
2911 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2912 $self->send_packet ("drawinfo $color $msg")
2913 }
2914 }
2915 }
2916}
2917
2318=item $client->ext_event ($type, %msg) 2918=item $client->ext_msg ($type, @msg)
2319 2919
2320Sends an exti event to the client. 2920Sends an ext event to the client.
2321 2921
2322=cut 2922=cut
2323 2923
2324sub cf::client::ext_event($$%) { 2924sub cf::client::ext_msg($$@) {
2325 my ($self, $type, %msg) = @_; 2925 my ($self, $type, @msg) = @_;
2326 2926
2927 if ($self->extcmd == 2) {
2928 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2929 } elsif ($self->extcmd == 1) { # TODO: remove
2327 $msg{msgtype} = "event_$type"; 2930 push @msg, msgtype => "event_$type";
2328 $self->send_packet ("ext " . cf::to_json \%msg); 2931 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2932 }
2933}
2934
2935=item $client->ext_reply ($msgid, @msg)
2936
2937Sends an ext reply to the client.
2938
2939=cut
2940
2941sub cf::client::ext_reply($$@) {
2942 my ($self, $id, @msg) = @_;
2943
2944 if ($self->extcmd == 2) {
2945 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2946 } elsif ($self->extcmd == 1) {
2947 #TODO: version 1, remove
2948 unshift @msg, msgtype => "reply", msgid => $id;
2949 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2950 }
2329} 2951}
2330 2952
2331=item $success = $client->query ($flags, "text", \&cb) 2953=item $success = $client->query ($flags, "text", \&cb)
2332 2954
2333Queues a query to the client, calling the given callback with 2955Queues a query to the client, calling the given callback with
2334the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2956the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2335C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2957C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2336 2958
2337Queries can fail, so check the return code. Or don't, as queries will become 2959Queries can fail, so check the return code. Or don't, as queries will
2338reliable at some point in the future. 2960become reliable at some point in the future.
2339 2961
2340=cut 2962=cut
2341 2963
2342sub cf::client::query { 2964sub cf::client::query {
2343 my ($self, $flags, $text, $cb) = @_; 2965 my ($self, $flags, $text, $cb) = @_;
… …
2351 utf8::encode $text; 2973 utf8::encode $text;
2352 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2974 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2353 2975
2354 $self->send_packet ($self->{query_queue}[0][0]) 2976 $self->send_packet ($self->{query_queue}[0][0])
2355 if @{ $self->{query_queue} } == 1; 2977 if @{ $self->{query_queue} } == 1;
2978
2979 1
2356} 2980}
2357 2981
2358cf::client->attach ( 2982cf::client->attach (
2983 on_connect => sub {
2984 my ($ns) = @_;
2985
2986 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2987 },
2359 on_reply => sub { 2988 on_reply => sub {
2360 my ($ns, $msg) = @_; 2989 my ($ns, $msg) = @_;
2361 2990
2362 # this weird shuffling is so that direct followup queries 2991 # this weird shuffling is so that direct followup queries
2363 # get handled first 2992 # get handled first
… …
2375 } else { 3004 } else {
2376 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3005 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2377 } 3006 }
2378 } 3007 }
2379 }, 3008 },
3009 on_exticmd => sub {
3010 my ($ns, $buf) = @_;
3011
3012 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3013
3014 if (ref $msg) {
3015 my ($type, $reply, @payload) =
3016 "ARRAY" eq ref $msg
3017 ? @$msg
3018 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3019
3020 my @reply;
3021
3022 if (my $cb = $EXTICMD{$type}) {
3023 @reply = $cb->($ns, @payload);
3024 }
3025
3026 $ns->ext_reply ($reply, @reply)
3027 if $reply;
3028
3029 } else {
3030 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3031 }
3032
3033 cf::override;
3034 },
2380); 3035);
2381 3036
2382=item $client->async (\&cb) 3037=item $client->async (\&cb)
2383 3038
2384Create a new coroutine, running the specified callback. The coroutine will 3039Create a new coroutine, running the specified callback. The coroutine will
… …
2425our $safe = new Safe "safe"; 3080our $safe = new Safe "safe";
2426our $safe_hole = new Safe::Hole; 3081our $safe_hole = new Safe::Hole;
2427 3082
2428$SIG{FPE} = 'IGNORE'; 3083$SIG{FPE} = 'IGNORE';
2429 3084
2430$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3085$safe->permit_only (Opcode::opset qw(
3086 :base_core :base_mem :base_orig :base_math
3087 grepstart grepwhile mapstart mapwhile
3088 sort time
3089));
2431 3090
2432# here we export the classes and methods available to script code 3091# here we export the classes and methods available to script code
2433 3092
2434=pod 3093=pod
2435 3094
2436The following functions and methods are available within a safe environment: 3095The following functions and methods are available within a safe environment:
2437 3096
2438 cf::object contr pay_amount pay_player map 3097 cf::object
3098 contr pay_amount pay_player map x y force_find force_add destroy
3099 insert remove name archname title slaying race decrease split
3100
2439 cf::object::player player 3101 cf::object::player
2440 cf::player peaceful 3102 player
2441 cf::map trigger 3103
3104 cf::player
3105 peaceful
3106
3107 cf::map
3108 trigger
2442 3109
2443=cut 3110=cut
2444 3111
2445for ( 3112for (
2446 ["cf::object" => qw(contr pay_amount pay_player map)], 3113 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3114 insert remove inv nrof name archname title slaying race
3115 decrease split destroy change_exp)],
2447 ["cf::object::player" => qw(player)], 3116 ["cf::object::player" => qw(player)],
2448 ["cf::player" => qw(peaceful)], 3117 ["cf::player" => qw(peaceful)],
2449 ["cf::map" => qw(trigger)], 3118 ["cf::map" => qw(trigger)],
2450) { 3119) {
2451 no strict 'refs'; 3120 no strict 'refs';
… …
2527# the server's init and main functions 3196# the server's init and main functions
2528 3197
2529sub load_facedata($) { 3198sub load_facedata($) {
2530 my ($path) = @_; 3199 my ($path) = @_;
2531 3200
3201 # HACK to clear player env face cache, we need some signal framework
3202 # for this (global event?)
3203 %ext::player_env::MUSIC_FACE_CACHE = ();
3204
3205 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3206
2532 warn "loading facedata from $path\n"; 3207 warn "loading facedata from $path\n";
2533 3208
2534 my $facedata; 3209 my $facedata;
2535 0 < aio_load $path, $facedata 3210 0 < aio_load $path, $facedata
2536 or die "$path: $!"; 3211 or die "$path: $!";
… …
2538 $facedata = Coro::Storable::thaw $facedata; 3213 $facedata = Coro::Storable::thaw $facedata;
2539 3214
2540 $facedata->{version} == 2 3215 $facedata->{version} == 2
2541 or cf::cleanup "$path: version mismatch, cannot proceed."; 3216 or cf::cleanup "$path: version mismatch, cannot proceed.";
2542 3217
3218 # patch in the exptable
3219 $facedata->{resource}{"res/exp_table"} = {
3220 type => FT_RSRC,
3221 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3222 };
3223 cf::cede_to_tick;
3224
2543 { 3225 {
2544 my $faces = $facedata->{faceinfo}; 3226 my $faces = $facedata->{faceinfo};
2545 3227
2546 while (my ($face, $info) = each %$faces) { 3228 while (my ($face, $info) = each %$faces) {
2547 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3229 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3230
2548 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3231 cf::face::set_visibility $idx, $info->{visibility};
3232 cf::face::set_magicmap $idx, $info->{magicmap};
2549 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3233 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2550 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3234 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2551 Coro::cede; 3235
3236 cf::cede_to_tick;
2552 } 3237 }
2553 3238
2554 while (my ($face, $info) = each %$faces) { 3239 while (my ($face, $info) = each %$faces) {
2555 next unless $info->{smooth}; 3240 next unless $info->{smooth};
3241
2556 my $idx = cf::face::find $face 3242 my $idx = cf::face::find $face
2557 or next; 3243 or next;
3244
2558 if (my $smooth = cf::face::find $info->{smooth}) { 3245 if (my $smooth = cf::face::find $info->{smooth}) {
3246 cf::face::set_smooth $idx, $smooth;
2559 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3247 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2560 } else { 3248 } else {
2561 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3249 warn "smooth face '$info->{smooth}' not found for face '$face'";
2562 } 3250 }
2563 Coro::cede; 3251
3252 cf::cede_to_tick;
2564 } 3253 }
2565 } 3254 }
2566 3255
2567 { 3256 {
2568 my $anims = $facedata->{animinfo}; 3257 my $anims = $facedata->{animinfo};
2569 3258
2570 while (my ($anim, $info) = each %$anims) { 3259 while (my ($anim, $info) = each %$anims) {
2571 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3260 cf::anim::set $anim, $info->{frames}, $info->{facings};
2572 Coro::cede; 3261 cf::cede_to_tick;
2573 } 3262 }
2574 3263
2575 cf::anim::invalidate_all; # d'oh 3264 cf::anim::invalidate_all; # d'oh
2576 } 3265 }
2577 3266
3267 {
3268 # TODO: for gcfclient pleasure, we should give resources
3269 # that gcfclient doesn't grok a >10000 face index.
3270 my $res = $facedata->{resource};
3271
3272 while (my ($name, $info) = each %$res) {
3273 if (defined $info->{type}) {
3274 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3275 my $data;
3276
3277 if ($info->{type} & 1) {
3278 # prepend meta info
3279
3280 my $meta = $enc->encode ({
3281 name => $name,
3282 %{ $info->{meta} || {} },
3283 });
3284
3285 $data = pack "(w/a*)*", $meta, $info->{data};
3286 } else {
3287 $data = $info->{data};
3288 }
3289
3290 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3291 cf::face::set_type $idx, $info->{type};
3292 } else {
3293 $RESOURCE{$name} = $info;
3294 }
3295
3296 cf::cede_to_tick;
3297 }
3298 }
3299
3300 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3301
2578 1 3302 1
2579} 3303}
2580 3304
3305cf::global->attach (on_resource_update => sub {
3306 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3307 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3308
3309 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3310 my $sound = $soundconf->{compat}[$_]
3311 or next;
3312
3313 my $face = cf::face::find "sound/$sound->[1]";
3314 cf::sound::set $sound->[0] => $face;
3315 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3316 }
3317
3318 while (my ($k, $v) = each %{$soundconf->{event}}) {
3319 my $face = cf::face::find "sound/$v";
3320 cf::sound::set $k => $face;
3321 }
3322 }
3323});
3324
3325register_exticmd fx_want => sub {
3326 my ($ns, $want) = @_;
3327
3328 while (my ($k, $v) = each %$want) {
3329 $ns->fx_want ($k, $v);
3330 }
3331};
3332
3333sub load_resource_file($) {
3334 my $guard = lock_acquire "load_resource_file";
3335
3336 my $status = load_resource_file_ $_[0];
3337 get_slot 0.1, 100;
3338 cf::arch::commit_load;
3339
3340 $status
3341}
3342
2581sub reload_regions { 3343sub reload_regions {
3344 # HACK to clear player env face cache, we need some signal framework
3345 # for this (global event?)
3346 %ext::player_env::MUSIC_FACE_CACHE = ();
3347
2582 load_resource_file "$MAPDIR/regions" 3348 load_resource_file "$MAPDIR/regions"
2583 or die "unable to load regions file\n"; 3349 or die "unable to load regions file\n";
3350
3351 for (cf::region::list) {
3352 $_->{match} = qr/$_->{match}/
3353 if exists $_->{match};
3354 }
2584} 3355}
2585 3356
2586sub reload_facedata { 3357sub reload_facedata {
2587 load_facedata "$DATADIR/facedata" 3358 load_facedata "$DATADIR/facedata"
2588 or die "unable to load facedata\n"; 3359 or die "unable to load facedata\n";
… …
2599} 3370}
2600 3371
2601sub reload_resources { 3372sub reload_resources {
2602 warn "reloading resource files...\n"; 3373 warn "reloading resource files...\n";
2603 3374
3375 reload_facedata;
3376 reload_archetypes;
2604 reload_regions; 3377 reload_regions;
2605 reload_facedata;
2606 #reload_archetypes;#d#
2607 reload_archetypes;
2608 reload_treasures; 3378 reload_treasures;
2609 3379
2610 warn "finished reloading resource files\n"; 3380 warn "finished reloading resource files\n";
2611} 3381}
2612 3382
2613sub init { 3383sub reload_config {
2614 reload_resources;
2615}
2616
2617sub cfg_load {
2618 open my $fh, "<:utf8", "$CONFDIR/config" 3384 open my $fh, "<:utf8", "$CONFDIR/config"
2619 or return; 3385 or return;
2620 3386
2621 local $/; 3387 local $/;
2622 *CFG = YAML::Syck::Load <$fh>; 3388 *CFG = YAML::Load <$fh>;
2623 3389
2624 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3390 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2625 3391
2626 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3392 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2627 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3393 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
2633 }; 3399 };
2634 warn $@ if $@; 3400 warn $@ if $@;
2635 } 3401 }
2636} 3402}
2637 3403
3404sub pidfile() {
3405 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3406 or die "$PIDFILE: $!";
3407 flock $fh, &Fcntl::LOCK_EX
3408 or die "$PIDFILE: flock: $!";
3409 $fh
3410}
3411
3412# make sure only one server instance is running at any one time
3413sub atomic {
3414 my $fh = pidfile;
3415
3416 my $pid = <$fh>;
3417 kill 9, $pid if $pid > 0;
3418
3419 seek $fh, 0, 0;
3420 print $fh $$;
3421}
3422
2638sub main { 3423sub main {
3424 cf::init_globals; # initialise logging
3425
3426 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3427 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3428 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3429 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3430
3431 cf::init_experience;
3432 cf::init_anim;
3433 cf::init_attackmess;
3434 cf::init_dynamic;
3435 cf::init_block;
3436
3437 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3438
2639 # we must not ever block the main coroutine 3439 # we must not ever block the main coroutine
2640 local $Coro::idle = sub { 3440 local $Coro::idle = sub {
2641 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3441 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2642 (async { 3442 (async {
2643 Event::one_event; 3443 $Coro::current->{desc} = "IDLE BUG HANDLER";
3444 EV::loop EV::LOOP_ONESHOT;
2644 })->prio (Coro::PRIO_MAX); 3445 })->prio (Coro::PRIO_MAX);
2645 }; 3446 };
2646 3447
2647 cfg_load; 3448 evthread_start IO::AIO::poll_fileno;
3449
3450 cf::sync_job {
3451 reload_resources;
3452 reload_config;
2648 db_init; 3453 db_init;
3454
3455 cf::load_settings;
3456 cf::load_materials;
3457 cf::init_uuid;
3458 cf::init_signals;
3459 cf::init_commands;
3460 cf::init_skills;
3461
3462 cf::init_beforeplay;
3463
3464 atomic;
3465
2649 load_extensions; 3466 load_extensions;
2650 3467
2651 $TICK_WATCHER->start; 3468 utime time, time, $RUNTIMEFILE;
3469
3470 # no (long-running) fork's whatsoever before this point(!)
3471 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3472
3473 (pop @POST_INIT)->(0) while @POST_INIT;
3474 };
3475
2652 Event::loop; 3476 EV::loop;
2653} 3477}
2654 3478
2655############################################################################# 3479#############################################################################
2656# initialisation and cleanup 3480# initialisation and cleanup
2657 3481
2658# install some emergency cleanup handlers 3482# install some emergency cleanup handlers
2659BEGIN { 3483BEGIN {
3484 our %SIGWATCHER = ();
2660 for my $signal (qw(INT HUP TERM)) { 3485 for my $signal (qw(INT HUP TERM)) {
2661 Event->signal ( 3486 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2662 reentrant => 0,
2663 data => WF_AUTOCANCEL,
2664 signal => $signal,
2665 prio => 0,
2666 cb => sub {
2667 cf::cleanup "SIG$signal"; 3487 cf::cleanup "SIG$signal";
2668 },
2669 ); 3488 };
2670 } 3489 }
2671} 3490}
2672 3491
2673sub write_runtime { 3492sub write_runtime_sync {
2674 my $runtime = "$LOCALDIR/runtime";
2675
2676 # first touch the runtime file to show we are still running: 3493 # first touch the runtime file to show we are still running:
2677 # the fsync below can take a very very long time. 3494 # the fsync below can take a very very long time.
2678 3495
2679 IO::AIO::aio_utime $runtime, undef, undef; 3496 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
2680 3497
2681 my $guard = cf::lock_acquire "write_runtime"; 3498 my $guard = cf::lock_acquire "write_runtime";
2682 3499
2683 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3500 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT, 0644
2684 or return; 3501 or return;
2685 3502
2686 my $value = $cf::RUNTIME + 90 + 10; 3503 my $value = $cf::RUNTIME + 90 + 10;
2687 # 10 is the runtime save interval, for a monotonic clock 3504 # 10 is the runtime save interval, for a monotonic clock
2688 # 60 allows for the watchdog to kill the server. 3505 # 60 allows for the watchdog to kill the server.
… …
2698 aio_utime $fh, undef, undef; 3515 aio_utime $fh, undef, undef;
2699 3516
2700 close $fh 3517 close $fh
2701 or return; 3518 or return;
2702 3519
2703 aio_rename "$runtime~", $runtime 3520 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
2704 and return; 3521 and return;
2705 3522
2706 warn "runtime file written.\n"; 3523 warn "runtime file written.\n";
2707 3524
2708 1 3525 1
3526}
3527
3528our $uuid_lock;
3529our $uuid_skip;
3530
3531sub write_uuid_sync($) {
3532 $uuid_skip ||= $_[0];
3533
3534 return if $uuid_lock;
3535 local $uuid_lock = 1;
3536
3537 my $uuid = "$LOCALDIR/uuid";
3538
3539 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3540 or return;
3541
3542 my $value = uuid_seq uuid_cur;
3543
3544 unless ($value) {
3545 warn "cowardly refusing to write zero uuid value!\n";
3546 return;
3547 }
3548
3549 my $value = uuid_str $value + $uuid_skip;
3550 $uuid_skip = 0;
3551
3552 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3553 and return;
3554
3555 # always fsync - this file is important
3556 aio_fsync $fh
3557 and return;
3558
3559 close $fh
3560 or return;
3561
3562 aio_rename "$uuid~", $uuid
3563 and return;
3564
3565 warn "uuid file written ($value).\n";
3566
3567 1
3568
3569}
3570
3571sub write_uuid($$) {
3572 my ($skip, $sync) = @_;
3573
3574 $sync ? write_uuid_sync $skip
3575 : async { write_uuid_sync $skip };
2709} 3576}
2710 3577
2711sub emergency_save() { 3578sub emergency_save() {
2712 my $freeze_guard = cf::freeze_mainloop; 3579 my $freeze_guard = cf::freeze_mainloop;
2713 3580
2714 warn "enter emergency perl save\n"; 3581 warn "emergency_perl_save: enter\n";
2715 3582
2716 cf::sync_job { 3583 cf::sync_job {
3584 # this is a trade-off: we want to be very quick here, so
3585 # save all maps without fsync, and later call a global sync
3586 # (which in turn might be very very slow)
3587 local $USE_FSYNC = 0;
3588
2717 # use a peculiar iteration method to avoid tripping on perl 3589 # use a peculiar iteration method to avoid tripping on perl
2718 # refcount bugs in for. also avoids problems with players 3590 # refcount bugs in for. also avoids problems with players
2719 # and maps saved/destroyed asynchronously. 3591 # and maps saved/destroyed asynchronously.
2720 warn "begin emergency player save\n"; 3592 warn "emergency_perl_save: begin player save\n";
2721 for my $login (keys %cf::PLAYER) { 3593 for my $login (keys %cf::PLAYER) {
2722 my $pl = $cf::PLAYER{$login} or next; 3594 my $pl = $cf::PLAYER{$login} or next;
2723 $pl->valid or next; 3595 $pl->valid or next;
3596 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2724 $pl->save; 3597 $pl->save;
2725 } 3598 }
2726 warn "end emergency player save\n"; 3599 warn "emergency_perl_save: end player save\n";
2727 3600
2728 warn "begin emergency map save\n"; 3601 warn "emergency_perl_save: begin map save\n";
2729 for my $path (keys %cf::MAP) { 3602 for my $path (keys %cf::MAP) {
2730 my $map = $cf::MAP{$path} or next; 3603 my $map = $cf::MAP{$path} or next;
2731 $map->valid or next; 3604 $map->valid or next;
2732 $map->save; 3605 $map->save;
2733 } 3606 }
2734 warn "end emergency map save\n"; 3607 warn "emergency_perl_save: end map save\n";
2735 3608
2736 warn "begin emergency database checkpoint\n"; 3609 warn "emergency_perl_save: begin database checkpoint\n";
2737 BDB::db_env_txn_checkpoint $DB_ENV; 3610 BDB::db_env_txn_checkpoint $DB_ENV;
2738 warn "end emergency database checkpoint\n"; 3611 warn "emergency_perl_save: end database checkpoint\n";
3612
3613 warn "emergency_perl_save: begin write uuid\n";
3614 write_uuid_sync 1;
3615 warn "emergency_perl_save: end write uuid\n";
2739 }; 3616 };
2740 3617
3618 warn "emergency_perl_save: starting sync()\n";
3619 IO::AIO::aio_sync sub {
3620 warn "emergency_perl_save: finished sync()\n";
3621 };
3622
2741 warn "leave emergency perl save\n"; 3623 warn "emergency_perl_save: leave\n";
2742} 3624}
2743 3625
2744sub post_cleanup { 3626sub post_cleanup {
2745 my ($make_core) = @_; 3627 my ($make_core) = @_;
2746 3628
2747 warn Carp::longmess "post_cleanup backtrace" 3629 warn Carp::longmess "post_cleanup backtrace"
2748 if $make_core; 3630 if $make_core;
3631
3632 my $fh = pidfile;
3633 unlink $PIDFILE if <$fh> == $$;
3634}
3635
3636# a safer delete_package, copied from Symbol
3637sub clear_package($) {
3638 my $pkg = shift;
3639
3640 # expand to full symbol table name if needed
3641 unless ($pkg =~ /^main::.*::$/) {
3642 $pkg = "main$pkg" if $pkg =~ /^::/;
3643 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3644 $pkg .= '::' unless $pkg =~ /::$/;
3645 }
3646
3647 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3648 my $stem_symtab = *{$stem}{HASH};
3649
3650 defined $stem_symtab and exists $stem_symtab->{$leaf}
3651 or return;
3652
3653 # clear all symbols
3654 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3655 for my $name (keys %$leaf_symtab) {
3656 _gv_clear *{"$pkg$name"};
3657# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3658 }
3659 warn "cleared package $pkg\n";#d#
2749} 3660}
2750 3661
2751sub do_reload_perl() { 3662sub do_reload_perl() {
2752 # can/must only be called in main 3663 # can/must only be called in main
2753 if ($Coro::current != $Coro::main) { 3664 if ($Coro::current != $Coro::main) {
2754 warn "can only reload from main coroutine"; 3665 warn "can only reload from main coroutine";
2755 return; 3666 return;
2756 } 3667 }
2757 3668
3669 return if $RELOAD++;
3670
3671 my $t1 = EV::time;
3672
3673 while ($RELOAD) {
2758 warn "reloading..."; 3674 warn "reloading...";
2759 3675
2760 warn "entering sync_job"; 3676 warn "entering sync_job";
2761 3677
2762 cf::sync_job { 3678 cf::sync_job {
2763 cf::write_runtime; # external watchdog should not bark 3679 cf::write_runtime_sync; # external watchdog should not bark
2764 cf::emergency_save; 3680 cf::emergency_save;
2765 cf::write_runtime; # external watchdog should not bark 3681 cf::write_runtime_sync; # external watchdog should not bark
2766 3682
2767 warn "syncing database to disk"; 3683 warn "syncing database to disk";
2768 BDB::db_env_txn_checkpoint $DB_ENV; 3684 BDB::db_env_txn_checkpoint $DB_ENV;
2769 3685
2770 # if anything goes wrong in here, we should simply crash as we already saved 3686 # if anything goes wrong in here, we should simply crash as we already saved
2771 3687
2772 warn "cancelling all WF_AUTOCANCEL watchers";
2773 for (Event::all_watchers) {
2774 $_->cancel if $_->data & WF_AUTOCANCEL;
2775 }
2776
2777 warn "flushing outstanding aio requests"; 3688 warn "flushing outstanding aio requests";
2778 for (;;) {
2779 BDB::flush;
2780 IO::AIO::flush;
2781 Coro::cede;
2782 last unless IO::AIO::nreqs || BDB::nreqs; 3689 while (IO::AIO::nreqs || BDB::nreqs) {
2783 warn "iterate..."; 3690 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
2784 }
2785
2786 ++$RELOAD;
2787
2788 warn "cancelling all extension coros";
2789 $_->cancel for values %EXT_CORO;
2790 %EXT_CORO = ();
2791
2792 warn "removing commands";
2793 %COMMAND = ();
2794
2795 warn "removing ext commands";
2796 %EXTCMD = ();
2797
2798 warn "unloading/nuking all extensions";
2799 for my $pkg (@EXTS) {
2800 warn "... unloading $pkg";
2801
2802 if (my $cb = $pkg->can ("unload")) {
2803 eval {
2804 $cb->($pkg);
2805 1
2806 } or warn "$pkg unloaded, but with errors: $@";
2807 } 3691 }
2808 3692
2809 warn "... nuking $pkg"; 3693 warn "cancelling all extension coros";
2810 Symbol::delete_package $pkg; 3694 $_->cancel for values %EXT_CORO;
2811 } 3695 %EXT_CORO = ();
2812 3696
2813 warn "unloading all perl modules loaded from $LIBDIR"; 3697 warn "removing commands";
2814 while (my ($k, $v) = each %INC) { 3698 %COMMAND = ();
2815 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2816 3699
3700 warn "removing ext/exti commands";
3701 %EXTCMD = ();
3702 %EXTICMD = ();
3703
3704 warn "unloading/nuking all extensions";
3705 for my $pkg (@EXTS) {
2817 warn "... unloading $k"; 3706 warn "... unloading $pkg";
2818 delete $INC{$k};
2819 3707
2820 $k =~ s/\.pm$//;
2821 $k =~ s/\//::/g;
2822
2823 if (my $cb = $k->can ("unload_module")) { 3708 if (my $cb = $pkg->can ("unload")) {
3709 eval {
2824 $cb->(); 3710 $cb->($pkg);
3711 1
3712 } or warn "$pkg unloaded, but with errors: $@";
3713 }
3714
3715 warn "... clearing $pkg";
3716 clear_package $pkg;
2825 } 3717 }
2826 3718
2827 Symbol::delete_package $k; 3719 warn "unloading all perl modules loaded from $LIBDIR";
3720 while (my ($k, $v) = each %INC) {
3721 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3722
3723 warn "... unloading $k";
3724 delete $INC{$k};
3725
3726 $k =~ s/\.pm$//;
3727 $k =~ s/\//::/g;
3728
3729 if (my $cb = $k->can ("unload_module")) {
3730 $cb->();
3731 }
3732
3733 clear_package $k;
2828 } 3734 }
2829 3735
2830 warn "getting rid of safe::, as good as possible"; 3736 warn "getting rid of safe::, as good as possible";
2831 Symbol::delete_package "safe::$_" 3737 clear_package "safe::$_"
2832 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3738 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2833 3739
2834 warn "unloading cf.pm \"a bit\""; 3740 warn "unloading cf.pm \"a bit\"";
2835 delete $INC{"cf.pm"}; 3741 delete $INC{"cf.pm"};
2836 delete $INC{"cf/pod.pm"}; 3742 delete $INC{"cf/pod.pm"};
2837 3743
2838 # don't, removes xs symbols, too, 3744 # don't, removes xs symbols, too,
2839 # and global variables created in xs 3745 # and global variables created in xs
2840 #Symbol::delete_package __PACKAGE__; 3746 #clear_package __PACKAGE__;
2841 3747
2842 warn "unload completed, starting to reload now"; 3748 warn "unload completed, starting to reload now";
2843 3749
2844 warn "reloading cf.pm"; 3750 warn "reloading cf.pm";
2845 require cf; 3751 require cf;
2846 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3752 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2847 3753
2848 warn "loading config and database again"; 3754 warn "loading config and database again";
2849 cf::cfg_load; 3755 cf::reload_config;
2850 3756
2851 warn "loading extensions"; 3757 warn "loading extensions";
2852 cf::load_extensions; 3758 cf::load_extensions;
2853 3759
3760 if ($REATTACH_ON_RELOAD) {
2854 warn "reattaching attachments to objects/players"; 3761 warn "reattaching attachments to objects/players";
2855 _global_reattach; # objects, sockets 3762 _global_reattach; # objects, sockets
2856 warn "reattaching attachments to maps"; 3763 warn "reattaching attachments to maps";
2857 reattach $_ for values %MAP; 3764 reattach $_ for values %MAP;
2858 warn "reattaching attachments to players"; 3765 warn "reattaching attachments to players";
2859 reattach $_ for values %PLAYER; 3766 reattach $_ for values %PLAYER;
3767 }
2860 3768
3769 warn "running post_init jobs";
3770 (pop @POST_INIT)->(1) while @POST_INIT;
3771
2861 warn "leaving sync_job"; 3772 warn "leaving sync_job";
2862 3773
2863 1 3774 1
2864 } or do { 3775 } or do {
2865 warn $@; 3776 warn $@;
2866 warn "error while reloading, exiting."; 3777 cf::cleanup "error while reloading, exiting.";
2867 exit 1;
2868 }; 3778 };
2869 3779
2870 warn "reloaded"; 3780 warn "reloaded";
3781 --$RELOAD;
3782 }
3783
3784 $t1 = EV::time - $t1;
3785 warn "reload completed in ${t1}s\n";
2871}; 3786};
2872 3787
2873our $RELOAD_WATCHER; # used only during reload 3788our $RELOAD_WATCHER; # used only during reload
2874 3789
2875sub reload_perl() { 3790sub reload_perl() {
2876 # doing reload synchronously and two reloads happen back-to-back, 3791 # doing reload synchronously and two reloads happen back-to-back,
2877 # coro crashes during coro_state_free->destroy here. 3792 # coro crashes during coro_state_free->destroy here.
2878 3793
2879 $RELOAD_WATCHER ||= Event->timer ( 3794 $RELOAD_WATCHER ||= cf::async {
2880 reentrant => 0, 3795 Coro::AIO::aio_wait cache_extensions;
2881 after => 0, 3796
2882 data => WF_AUTOCANCEL, 3797 $RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
2883 cb => sub {
2884 do_reload_perl; 3798 do_reload_perl;
2885 undef $RELOAD_WATCHER; 3799 undef $RELOAD_WATCHER;
2886 }, 3800 };
2887 ); 3801 };
2888} 3802}
2889 3803
2890register_command "reload" => sub { 3804register_command "reload" => sub {
2891 my ($who, $arg) = @_; 3805 my ($who, $arg) = @_;
2892 3806
2893 if ($who->flag (FLAG_WIZ)) { 3807 if ($who->flag (FLAG_WIZ)) {
2894 $who->message ("reloading server."); 3808 $who->message ("reloading server.");
3809 async {
3810 $Coro::current->{desc} = "perl_reload";
2895 async { reload_perl }; 3811 reload_perl;
3812 };
2896 } 3813 }
2897}; 3814};
2898 3815
2899unshift @INC, $LIBDIR; 3816unshift @INC, $LIBDIR;
2900 3817
… …
2902 3819
2903our @WAIT_FOR_TICK; 3820our @WAIT_FOR_TICK;
2904our @WAIT_FOR_TICK_BEGIN; 3821our @WAIT_FOR_TICK_BEGIN;
2905 3822
2906sub wait_for_tick { 3823sub wait_for_tick {
2907 return unless $TICK_WATCHER->is_active;
2908 return if $Coro::current == $Coro::main; 3824 return if tick_inhibit || $Coro::current == $Coro::main;
2909 3825
2910 my $signal = new Coro::Signal; 3826 my $signal = new Coro::Signal;
2911 push @WAIT_FOR_TICK, $signal; 3827 push @WAIT_FOR_TICK, $signal;
2912 $signal->wait; 3828 $signal->wait;
2913} 3829}
2914 3830
2915sub wait_for_tick_begin { 3831sub wait_for_tick_begin {
2916 return unless $TICK_WATCHER->is_active;
2917 return if $Coro::current == $Coro::main; 3832 return if tick_inhibit || $Coro::current == $Coro::main;
2918 3833
2919 my $signal = new Coro::Signal; 3834 my $signal = new Coro::Signal;
2920 push @WAIT_FOR_TICK_BEGIN, $signal; 3835 push @WAIT_FOR_TICK_BEGIN, $signal;
2921 $signal->wait; 3836 $signal->wait;
2922} 3837}
2923 3838
2924 my $min = 1e6;#d# 3839sub tick {
2925 my $avg = 10;
2926$TICK_WATCHER = Event->timer (
2927 reentrant => 0,
2928 parked => 1,
2929 prio => 0,
2930 at => $NEXT_TICK || $TICK,
2931 data => WF_AUTOCANCEL,
2932 cb => sub {
2933 if ($Coro::current != $Coro::main) { 3840 if ($Coro::current != $Coro::main) {
2934 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3841 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2935 unless ++$bug_warning > 10; 3842 unless ++$bug_warning > 10;
2936 return; 3843 return;
2937 } 3844 }
2938 3845
2939 $NOW = $tick_start = Event::time;
2940
2941 cf::server_tick; # one server iteration 3846 cf::server_tick; # one server iteration
2942 3847
2943 0 && sync_job {#d# 3848 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2944 for(1..10) { 3849 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2945 my $t = Event::time; 3850 Coro::async_pool {
2946 my $map = my $map = new_from_path cf::map "/tmp/x.map" 3851 $Coro::current->{desc} = "runtime saver";
2947 or die; 3852 write_runtime_sync
2948 3853 or warn "ERROR: unable to write runtime file: $!";
2949 $map->width (50);
2950 $map->height (50);
2951 $map->alloc;
2952 $map->_load_objects ("/tmp/x.map", 1);
2953 my $t = Event::time - $t;
2954
2955 #next unless $t < 0.0013;#d#
2956 if ($t < $min) {
2957 $min = $t;
2958 }
2959 $avg = $avg * 0.99 + $t * 0.01;
2960 }
2961 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2962 exit 0;
2963 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2964 }; 3854 };
3855 }
2965 3856
2966 $RUNTIME += $TICK;
2967 $NEXT_TICK += $TICK;
2968
2969 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2970 $NEXT_RUNTIME_WRITE = $NOW + 10;
2971 Coro::async_pool {
2972 write_runtime
2973 or warn "ERROR: unable to write runtime file: $!";
2974 };
2975 }
2976
2977# my $AFTER = Event::time;
2978# warn $AFTER - $NOW;#d#
2979
2980 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3857 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2981 $sig->send; 3858 $sig->send;
2982 } 3859 }
2983 while (my $sig = shift @WAIT_FOR_TICK) { 3860 while (my $sig = shift @WAIT_FOR_TICK) {
2984 $sig->send; 3861 $sig->send;
2985 } 3862 }
2986 3863
2987 $NOW = Event::time; 3864 $LOAD = ($NOW - $TICK_START) / $TICK;
2988
2989 # if we are delayed by four ticks or more, skip them all
2990 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2991
2992 $TICK_WATCHER->at ($NEXT_TICK);
2993 $TICK_WATCHER->start;
2994
2995 $LOAD = ($NOW - $tick_start) / $TICK;
2996 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3865 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2997 3866
2998 _post_tick; 3867 if (0) {
2999 3868 if ($NEXT_TICK) {
3000 3869 my $jitter = $TICK_START - $NEXT_TICK;
3870 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3871 warn "jitter $JITTER\n";#d#
3872 }
3001 }, 3873 }
3002); 3874}
3003 3875
3004{ 3876{
3005 BDB::max_poll_time $TICK * 0.1; 3877 # configure BDB
3006 $BDB_POLL_WATCHER = Event->io ( 3878
3007 reentrant => 0,
3008 fd => BDB::poll_fileno,
3009 poll => 'r',
3010 prio => 0,
3011 data => WF_AUTOCANCEL,
3012 cb => \&BDB::poll_cb,
3013 );
3014 BDB::min_parallel 8; 3879 BDB::min_parallel 8;
3015 3880 BDB::max_poll_reqs $TICK * 0.1;
3016 BDB::set_sync_prepare { 3881 $AnyEvent::BDB::WATCHER->priority (1);
3017 my $status;
3018 my $current = $Coro::current;
3019 (
3020 sub {
3021 $status = $!;
3022 $current->ready; undef $current;
3023 },
3024 sub {
3025 Coro::schedule while defined $current;
3026 $! = $status;
3027 },
3028 )
3029 };
3030 3882
3031 unless ($DB_ENV) { 3883 unless ($DB_ENV) {
3032 $DB_ENV = BDB::db_env_create; 3884 $DB_ENV = BDB::db_env_create;
3885 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3886 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
3887 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3888 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3889 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3033 3890
3034 cf::sync_job { 3891 cf::sync_job {
3035 eval { 3892 eval {
3036 BDB::db_env_open 3893 BDB::db_env_open
3037 $DB_ENV, 3894 $DB_ENV,
… …
3039 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3896 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3040 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3897 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3041 0666; 3898 0666;
3042 3899
3043 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3900 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3044
3045 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3046 $DB_ENV->set_lk_detect;
3047 }; 3901 };
3048 3902
3049 cf::cleanup "db_env_open(db): $@" if $@; 3903 cf::cleanup "db_env_open(db): $@" if $@;
3050 }; 3904 };
3051 } 3905 }
3906
3907 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3908 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3909 };
3910 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3911 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3912 };
3913 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3914 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3915 };
3052} 3916}
3053 3917
3054{ 3918{
3919 # configure IO::AIO
3920
3055 IO::AIO::min_parallel 8; 3921 IO::AIO::min_parallel 8;
3056
3057 undef $Coro::AIO::WATCHER;
3058 IO::AIO::max_poll_time $TICK * 0.1; 3922 IO::AIO::max_poll_time $TICK * 0.1;
3059 $AIO_POLL_WATCHER = Event->io ( 3923 undef $AnyEvent::AIO::WATCHER;
3060 reentrant => 0,
3061 data => WF_AUTOCANCEL,
3062 fd => IO::AIO::poll_fileno,
3063 poll => 'r',
3064 prio => 6,
3065 cb => \&IO::AIO::poll_cb,
3066 );
3067} 3924}
3068 3925
3069my $_log_backtrace; 3926my $_log_backtrace;
3070 3927
3071sub _log_backtrace { 3928sub _log_backtrace {
… …
3074 $msg =~ s/\n//; 3931 $msg =~ s/\n//;
3075 3932
3076 # limit the # of concurrent backtraces 3933 # limit the # of concurrent backtraces
3077 if ($_log_backtrace < 2) { 3934 if ($_log_backtrace < 2) {
3078 ++$_log_backtrace; 3935 ++$_log_backtrace;
3936 my $perl_bt = Carp::longmess $msg;
3079 async { 3937 async {
3938 $Coro::current->{desc} = "abt $msg";
3939
3080 my @bt = fork_call { 3940 my @bt = fork_call {
3081 @addr = map { sprintf "%x", $_ } @addr; 3941 @addr = map { sprintf "%x", $_ } @addr;
3082 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3942 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3083 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3943 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3084 or die "addr2line: $!"; 3944 or die "addr2line: $!";
… …
3092 } 3952 }
3093 3953
3094 @funcs 3954 @funcs
3095 }; 3955 };
3096 3956
3097 LOG llevInfo, "[ABT] $msg\n"; 3957 LOG llevInfo, "[ABT] $perl_bt\n";
3958 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3098 LOG llevInfo, "[ABT] $_\n" for @bt; 3959 LOG llevInfo, "[ABT] $_\n" for @bt;
3099 --$_log_backtrace; 3960 --$_log_backtrace;
3100 }; 3961 };
3101 } else { 3962 } else {
3102 LOG llevInfo, "[ABT] $msg\n"; 3963 LOG llevInfo, "[ABT] $msg\n";

Diff Legend

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