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

Diff Legend

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