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

Diff Legend

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