ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.278 by root, Mon Jun 11 21:38:14 2007 UTC vs.
Revision 1.520 by root, Fri Apr 16 02:37:50 2010 UTC

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

Diff Legend

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