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.444 by root, Mon Sep 8 11:27:25 2008 UTC vs.
Revision 1.561 by root, Fri Apr 22 06:10:33 2011 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify 6# Deliantra is free software: you can redistribute it and/or modify it under
7# it under the terms of the GNU General Public License as published by 7# the terms of the Affero GNU General Public License as published by the
8# the Free Software Foundation, either version 3 of the License, or 8# Free Software Foundation, either version 3 of the License, or (at your
9# (at your option) any later version. 9# option) any later version.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>. 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
18# 19#
19# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
20# 21#
21 22
22package cf; 23package cf;
23 24
24use 5.10.0; 25use common::sense;
25use utf8;
26use strict "vars", "subs";
27 26
28use Symbol; 27use Symbol;
29use List::Util; 28use List::Util;
30use Socket; 29use Socket;
31use EV; 30use EV;
32use Opcode; 31use Opcode;
33use Safe; 32use Safe;
34use Safe::Hole; 33use Safe::Hole;
35use Storable (); 34use Storable ();
35use Carp ();
36 36
37use Guard ();
37use Coro (); 38use Coro ();
38use Coro::State; 39use Coro::State;
39use Coro::Handle; 40use Coro::Handle;
40use Coro::EV; 41use Coro::EV;
41use Coro::AnyEvent; 42use Coro::AnyEvent;
42use Coro::Timer; 43use Coro::Timer;
43use Coro::Signal; 44use Coro::Signal;
44use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
45use Coro::AnyEvent; 47use Coro::AnyEvent;
46use Coro::AIO; 48use Coro::AIO;
47use Coro::BDB 1.6; 49use Coro::BDB 1.6;
48use Coro::Storable; 50use Coro::Storable;
49use Coro::Util (); 51use Coro::Util ();
50 52
51use JSON::XS 2.01 (); 53use JSON::XS 2.01 ();
52use BDB (); 54use BDB ();
53use Data::Dumper; 55use Data::Dumper;
54use Digest::MD5;
55use Fcntl; 56use Fcntl;
56use YAML (); 57use YAML::XS ();
57use IO::AIO (); 58use IO::AIO ();
58use Time::HiRes; 59use Time::HiRes;
59use Compress::LZF; 60use Compress::LZF;
60use Digest::MD5 (); 61use Digest::MD5 ();
61 62
… …
63 64
64# configure various modules to our taste 65# configure various modules to our taste
65# 66#
66$Storable::canonical = 1; # reduce rsync transfers 67$Storable::canonical = 1; # reduce rsync transfers
67Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 68Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
69
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71
72# make sure c-lzf reinitialises itself
73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
68Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
69 75
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 76# strictly for debugging
77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
71 78
72sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
80
81our @ORIG_INC;
73 82
74our %COMMAND = (); 83our %COMMAND = ();
75our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
76 85
77our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
78our %EXTCMD = (); 87our %EXTCMD = ();
79our %EXTICMD = (); 88our %EXTICMD = ();
80our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
81our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
82 91
83our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
84our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
85 96
86our $CONFDIR = confdir; 97our $CONFDIR = confdir;
98
87our $DATADIR = datadir; 99our $DATADIR = datadir;
88our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
89our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
90our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
103
91our $LOCALDIR = localdir; 104our $LOCALDIR = localdir;
92our $TMPDIR = "$LOCALDIR/" . tmpdir; 105our $TMPDIR = "$LOCALDIR/" . tmpdir;
93our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 106our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
94our $PLAYERDIR = "$LOCALDIR/" . playerdir; 107our $PLAYERDIR = "$LOCALDIR/" . playerdir;
95our $RANDOMDIR = "$LOCALDIR/random"; 108our $RANDOMDIR = "$LOCALDIR/random";
96our $BDBDIR = "$LOCALDIR/db"; 109our $BDBDIR = "$LOCALDIR/db";
110our $PIDFILE = "$LOCALDIR/pid";
111our $RUNTIMEFILE = "$LOCALDIR/runtime";
112
97our %RESOURCE; 113our %RESOURCE; # unused
114
115our $OUTPUT_RATE_MIN = 3000;
116our $OUTPUT_RATE_MAX = 1000000;
117
118our $MAX_LINKS = 32; # how many chained exits to follow
119our $VERBOSE_IO = 1;
98 120
99our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 121our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
100our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 122our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
101our $NEXT_TICK; 123our $NEXT_TICK;
102our $USE_FSYNC = 1; # use fsync to write maps - default off 124our $USE_FSYNC = 1; # use fsync to write maps - default on
103 125
104our $BDB_DEADLOCK_WATCHER; 126our $BDB_DEADLOCK_WATCHER;
105our $BDB_CHECKPOINT_WATCHER; 127our $BDB_CHECKPOINT_WATCHER;
106our $BDB_TRICKLE_WATCHER; 128our $BDB_TRICKLE_WATCHER;
107our $DB_ENV; 129our $DB_ENV;
108 130
131our @EXTRA_MODULES = qw(pod match mapscript incloader);
132
109our %CFG; 133our %CFG;
110 134
111our $UPTIME; $UPTIME ||= time; 135our $UPTIME; $UPTIME ||= time;
112our $RUNTIME; 136our $RUNTIME;
113our $NOW; 137our $NOW;
… …
122our $LOAD; # a number between 0 (idle) and 1 (too many objects) 146our $LOAD; # a number between 0 (idle) and 1 (too many objects)
123our $LOADAVG; # same thing, but with alpha-smoothing 147our $LOADAVG; # same thing, but with alpha-smoothing
124our $JITTER; # average jitter 148our $JITTER; # average jitter
125our $TICK_START; # for load detecting purposes 149our $TICK_START; # for load detecting purposes
126 150
151our @POST_INIT;
152
153our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
154our $REALLY_UNLOOP; # never set to true, please :)
155
127binmode STDOUT; 156binmode STDOUT;
128binmode STDERR; 157binmode STDERR;
129 158
130# read virtual server time, if available 159# read virtual server time, if available
131unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 160unless ($RUNTIME || !-e $RUNTIMEFILE) {
132 open my $fh, "<", "$LOCALDIR/runtime" 161 open my $fh, "<", $RUNTIMEFILE
133 or die "unable to read runtime file: $!"; 162 or die "unable to read $RUNTIMEFILE file: $!";
134 $RUNTIME = <$fh> + 0.; 163 $RUNTIME = <$fh> + 0.;
135} 164}
165
166eval "sub TICK() { $TICK } 1" or die;
136 167
137mkdir $_ 168mkdir $_
138 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 169 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
139 170
140our $EMERGENCY_POSITION; 171our $EMERGENCY_POSITION;
141 172
142sub cf::map::normalise; 173sub cf::map::normalise;
174
175sub in_main() {
176 $Coro::current == $Coro::main
177}
178
179#############################################################################
180
181%REFLECT = ();
182for (@REFLECT) {
183 my $reflect = JSON::XS::decode_json $_;
184 $REFLECT{$reflect->{class}} = $reflect;
185}
186
187# this is decidedly evil
188$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
143 189
144############################################################################# 190#############################################################################
145 191
146=head2 GLOBAL VARIABLES 192=head2 GLOBAL VARIABLES
147 193
… …
189from wherever your confdir points to. 235from wherever your confdir points to.
190 236
191=item cf::wait_for_tick, cf::wait_for_tick_begin 237=item cf::wait_for_tick, cf::wait_for_tick_begin
192 238
193These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 239These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
194returns directly I<after> the tick processing (and consequently, can only wake one process 240returns directly I<after> the tick processing (and consequently, can only wake one thread
195per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 241per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
196 242
243=cut
244
245sub wait_for_tick();
246sub wait_for_tick_begin();
247
197=item @cf::INVOKE_RESULTS 248=item @cf::INVOKE_RESULTS
198 249
199This array contains the results of the last C<invoke ()> call. When 250This array contains the results of the last C<invoke ()> call. When
200C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 251C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
201that call. 252that call.
202 253
254=item %cf::REFLECT
255
256Contains, for each (C++) class name, a hash reference with information
257about object members (methods, scalars, arrays and flags) and other
258metadata, which is useful for introspection.
259
203=back 260=back
204 261
205=cut 262=cut
206 263
207BEGIN { 264sub error(@) { LOG llevError, join "", @_ }
208 *CORE::GLOBAL::warn = sub { 265sub warn (@) { LOG llevWarn , join "", @_ }
266sub info (@) { LOG llevInfo , join "", @_ }
267sub debug(@) { LOG llevDebug, join "", @_ }
268sub trace(@) { LOG llevTrace, join "", @_ }
269
270$Coro::State::WARNHOOK = sub {
209 my $msg = join "", @_; 271 my $msg = join "", @_;
210 272
211 $msg .= "\n" 273 $msg .= "\n"
212 unless $msg =~ /\n$/; 274 unless $msg =~ /\n$/;
213 275
214 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 276 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
215 277
216 LOG llevError, $msg; 278 LOG llevWarn, $msg;
217 }; 279};
218}
219 280
220$Coro::State::DIEHOOK = sub { 281$Coro::State::DIEHOOK = sub {
221 return unless $^S eq 0; # "eq", not "==" 282 return unless $^S eq 0; # "eq", not "=="
222 283
223 if ($Coro::current == $Coro::main) {#d# 284 error Carp::longmess $_[0];
285
286 if (in_main) {#d#
224 warn "DIEHOOK called in main context, Coro bug?\n";#d# 287 error "DIEHOOK called in main context, Coro bug?\n";#d#
225 return;#d# 288 return;#d#
226 }#d# 289 }#d#
227 290
228 # kill coroutine otherwise 291 # kill coroutine otherwise
229 warn Carp::longmess $_[0];
230 Coro::terminate 292 Coro::terminate
231}; 293};
232
233$SIG{__DIE__} = sub { }; #d#?
234 294
235@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 295@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
236@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 296@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
237@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 297@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
238@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 298@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
252)) { 312)) {
253 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 313 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
254} 314}
255 315
256$EV::DIED = sub { 316$EV::DIED = sub {
257 warn "error in event callback: @_"; 317 Carp::cluck "error in event callback: @_";
258}; 318};
319
320#############################################################################
321
322sub fork_call(&@);
323sub get_slot($;$$);
259 324
260############################################################################# 325#############################################################################
261 326
262=head2 UTILITY FUNCTIONS 327=head2 UTILITY FUNCTIONS
263 328
… …
284 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 349 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
285 $d 350 $d
286 } || "[unable to dump $_[0]: '$@']"; 351 } || "[unable to dump $_[0]: '$@']";
287} 352}
288 353
354=item $scalar = load_file $path
355
356Loads the given file from path and returns its contents. Croaks on error
357and can block.
358
359=cut
360
361sub load_file($) {
362 0 <= aio_load $_[0], my $data
363 or Carp::croak "$_[0]: $!";
364
365 $data
366}
367
289=item $ref = cf::decode_json $json 368=item $ref = cf::decode_json $json
290 369
291Converts a JSON string into the corresponding perl data structure. 370Converts a JSON string into the corresponding perl data structure.
292 371
293=item $json = cf::encode_json $ref 372=item $json = cf::encode_json $ref
… …
299our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 378our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
300 379
301sub encode_json($) { $json_coder->encode ($_[0]) } 380sub encode_json($) { $json_coder->encode ($_[0]) }
302sub decode_json($) { $json_coder->decode ($_[0]) } 381sub decode_json($) { $json_coder->decode ($_[0]) }
303 382
383=item $ref = cf::decode_storable $scalar
384
385Same as Coro::Storable::thaw, so blocks.
386
387=cut
388
389BEGIN { *decode_storable = \&Coro::Storable::thaw }
390
391=item $ref = cf::decode_yaml $scalar
392
393Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
394
395=cut
396
397sub decode_yaml($) {
398 fork_call { YAML::XS::Load $_[0] } @_
399}
400
401=item $scalar = cf::unlzf $scalar
402
403Same as Compress::LZF::compress, but takes server ticks into account, so
404blocks.
405
406=cut
407
408sub unlzf($) {
409 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
410 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
411 Compress::LZF::decompress $_[0]
412}
413
414=item cf::post_init { BLOCK }
415
416Execute the given codeblock, I<after> all extensions have been (re-)loaded,
417but I<before> the server starts ticking again.
418
419The codeblock will have a single boolean argument to indicate whether this
420is a reload or not.
421
422=cut
423
424sub post_init(&) {
425 push @POST_INIT, shift;
426}
427
428sub _post_init {
429 trace "running post_init jobs";
430
431 # run them in parallel...
432
433 my @join;
434
435 while () {
436 push @join, map &Coro::async ($_, 0), @POST_INIT;
437 @POST_INIT = ();
438
439 @join or last;
440
441 (pop @join)->join;
442 }
443}
444
304=item cf::lock_wait $string 445=item cf::lock_wait $string
305 446
306Wait until the given lock is available. See cf::lock_acquire. 447Wait until the given lock is available. See cf::lock_acquire.
307 448
308=item my $lock = cf::lock_acquire $string 449=item my $lock = cf::lock_acquire $string
309 450
310Wait until the given lock is available and then acquires it and returns 451Wait until the given lock is available and then acquires it and returns
311a Coro::guard object. If the guard object gets destroyed (goes out of scope, 452a L<Guard> object. If the guard object gets destroyed (goes out of scope,
312for example when the coroutine gets canceled), the lock is automatically 453for example when the coroutine gets canceled), the lock is automatically
313returned. 454returned.
314 455
315Locks are *not* recursive, locking from the same coro twice results in a 456Locks are *not* recursive, locking from the same coro twice results in a
316deadlocked coro. 457deadlocked coro.
… …
322 463
323Return true if the lock is currently active, i.e. somebody has locked it. 464Return true if the lock is currently active, i.e. somebody has locked it.
324 465
325=cut 466=cut
326 467
327our %LOCK; 468our $LOCKS = new Coro::SemaphoreSet;
328our %LOCKER;#d#
329 469
330sub lock_wait($) { 470sub lock_wait($) {
331 my ($key) = @_; 471 $LOCKS->wait ($_[0]);
332
333 if ($LOCKER{$key} == $Coro::current) {#d#
334 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
335 return;#d#
336 }#d#
337
338 # wait for lock, if any
339 while ($LOCK{$key}) {
340 push @{ $LOCK{$key} }, $Coro::current;
341 Coro::schedule;
342 }
343} 472}
344 473
345sub lock_acquire($) { 474sub lock_acquire($) {
346 my ($key) = @_; 475 $LOCKS->guard ($_[0])
347
348 # wait, to be sure we are not locked
349 lock_wait $key;
350
351 $LOCK{$key} = [];
352 $LOCKER{$key} = $Coro::current;#d#
353
354 Coro::guard {
355 delete $LOCKER{$key};#d#
356 # wake up all waiters, to be on the safe side
357 $_->ready for @{ delete $LOCK{$key} };
358 }
359} 476}
360 477
361sub lock_active($) { 478sub lock_active($) {
362 my ($key) = @_; 479 $LOCKS->count ($_[0]) < 1
363
364 ! ! $LOCK{$key}
365} 480}
366 481
367sub freeze_mainloop { 482sub freeze_mainloop {
368 tick_inhibit_inc; 483 tick_inhibit_inc;
369 484
370 Coro::guard \&tick_inhibit_dec; 485 &Guard::guard (\&tick_inhibit_dec);
371} 486}
372 487
373=item cf::periodic $interval, $cb 488=item cf::periodic $interval, $cb
374 489
375Like EV::periodic, but randomly selects a starting point so that the actions 490Like EV::periodic, but randomly selects a starting point so that the actions
376get spread over timer. 491get spread over time.
377 492
378=cut 493=cut
379 494
380sub periodic($$) { 495sub periodic($$) {
381 my ($interval, $cb) = @_; 496 my ($interval, $cb) = @_;
… …
385 EV::periodic $start, $interval, 0, $cb 500 EV::periodic $start, $interval, 0, $cb
386} 501}
387 502
388=item cf::get_slot $time[, $priority[, $name]] 503=item cf::get_slot $time[, $priority[, $name]]
389 504
390Allocate $time seconds of blocking CPU time at priority C<$priority>: 505Allocate $time seconds of blocking CPU time at priority C<$priority>
391This call blocks and returns only when you have at least C<$time> seconds 506(default: 0): This call blocks and returns only when you have at least
392of cpu time till the next tick. The slot is only valid till the next cede. 507C<$time> seconds of cpu time till the next tick. The slot is only valid
508till the next cede.
509
510Background jobs should use a priority les than zero, interactive jobs
511should use 100 or more.
393 512
394The optional C<$name> can be used to identify the job to run. It might be 513The optional C<$name> can be used to identify the job to run. It might be
395used for statistical purposes and should identify the same time-class. 514used for statistical purposes and should identify the same time-class.
396 515
397Useful for short background jobs. 516Useful for short background jobs.
398 517
399=cut 518=cut
400 519
401our @SLOT_QUEUE; 520our @SLOT_QUEUE;
402our $SLOT_QUEUE; 521our $SLOT_QUEUE;
522our $SLOT_DECAY = 0.9;
403 523
404$SLOT_QUEUE->cancel if $SLOT_QUEUE; 524$SLOT_QUEUE->cancel if $SLOT_QUEUE;
405$SLOT_QUEUE = Coro::async { 525$SLOT_QUEUE = Coro::async {
406 $Coro::current->desc ("timeslot manager"); 526 $Coro::current->desc ("timeslot manager");
407 527
408 my $signal = new Coro::Signal; 528 my $signal = new Coro::Signal;
529 my $busy;
409 530
410 while () { 531 while () {
411 next_job: 532 next_job:
533
412 my $avail = cf::till_tick; 534 my $avail = cf::till_tick;
413 if ($avail > 0.01) { 535
414 for (0 .. $#SLOT_QUEUE) { 536 for (0 .. $#SLOT_QUEUE) {
415 if ($SLOT_QUEUE[$_][0] < $avail) { 537 if ($SLOT_QUEUE[$_][0] <= $avail) {
538 $busy = 0;
416 my $job = splice @SLOT_QUEUE, $_, 1, (); 539 my $job = splice @SLOT_QUEUE, $_, 1, ();
417 $job->[2]->send; 540 $job->[2]->send;
418 Coro::cede; 541 Coro::cede;
419 goto next_job; 542 goto next_job;
420 } 543 } else {
544 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
421 } 545 }
422 } 546 }
423 547
424 if (@SLOT_QUEUE) { 548 if (@SLOT_QUEUE) {
425 # we do not use wait_for_tick() as it returns immediately when tick is inactive 549 # we do not use wait_for_tick() as it returns immediately when tick is inactive
426 push @cf::WAIT_FOR_TICK, $signal; 550 push @cf::WAIT_FOR_TICK, $signal;
427 $signal->wait; 551 $signal->wait;
428 } else { 552 } else {
553 $busy = 0;
429 Coro::schedule; 554 Coro::schedule;
430 } 555 }
431 } 556 }
432}; 557};
433 558
434sub get_slot($;$$) { 559sub get_slot($;$$) {
435 return if tick_inhibit || $Coro::current == $Coro::main; 560 return if tick_inhibit || $Coro::current == $Coro::main;
436 561
437 my ($time, $pri, $name) = @_; 562 my ($time, $pri, $name) = @_;
438 563
439 $time = $TICK * .6 if $time > $TICK * .6; 564 $time = clamp $time, 0.01, $TICK * .6;
565
440 my $sig = new Coro::Signal; 566 my $sig = new Coro::Signal;
441 567
442 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 568 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
443 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 569 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
444 $SLOT_QUEUE->ready; 570 $SLOT_QUEUE->ready;
… …
470=cut 596=cut
471 597
472sub sync_job(&) { 598sub sync_job(&) {
473 my ($job) = @_; 599 my ($job) = @_;
474 600
475 if ($Coro::current == $Coro::main) { 601 if (in_main) {
476 my $time = EV::time; 602 my $time = AE::time;
477 603
478 # this is the main coro, too bad, we have to block 604 # this is the main coro, too bad, we have to block
479 # till the operation succeeds, freezing the server :/ 605 # till the operation succeeds, freezing the server :/
480 606
481 LOG llevError, Carp::longmess "sync job";#d# 607 #LOG llevError, Carp::longmess "sync job";#d#
482 608
483 my $freeze_guard = freeze_mainloop; 609 my $freeze_guard = freeze_mainloop;
484 610
485 my $busy = 1; 611 my $busy = 1;
486 my @res; 612 my @res;
487 613
488 (async { 614 (async {
489 $Coro::current->desc ("sync job coro"); 615 $Coro::current->desc ("sync job coro");
490 @res = eval { $job->() }; 616 @res = eval { $job->() };
491 warn $@ if $@; 617 error $@ if $@;
492 undef $busy; 618 undef $busy;
493 })->prio (Coro::PRIO_MAX); 619 })->prio (Coro::PRIO_MAX);
494 620
495 while ($busy) { 621 while ($busy) {
496 if (Coro::nready) { 622 if (Coro::nready) {
… …
498 } else { 624 } else {
499 EV::loop EV::LOOP_ONESHOT; 625 EV::loop EV::LOOP_ONESHOT;
500 } 626 }
501 } 627 }
502 628
503 my $time = EV::time - $time; 629 my $time = AE::time - $time;
504 630
505 $TICK_START += $time; # do not account sync jobs to server load 631 $TICK_START += $time; # do not account sync jobs to server load
506 632
507 wantarray ? @res : $res[0] 633 wantarray ? @res : $res[0]
508 } else { 634 } else {
… …
530 $EXT_CORO{$coro+0} = $coro; 656 $EXT_CORO{$coro+0} = $coro;
531 657
532 $coro 658 $coro
533} 659}
534 660
535=item fork_call { }, $args 661=item fork_call { }, @args
536 662
537Executes the given code block with the given arguments in a seperate 663Executes the given code block with the given arguments in a seperate
538process, returning the results. Everything must be serialisable with 664process, returning the results. Everything must be serialisable with
539Coro::Storable. May, of course, block. Note that the executed sub may 665Coro::Storable. May, of course, block. Note that the executed sub may
540never block itself or use any form of event handling. 666never block itself or use any form of event handling.
541 667
542=cut 668=cut
543 669
670sub post_fork {
671 reset_signals;
672}
673
544sub fork_call(&@) { 674sub fork_call(&@) {
545 my ($cb, @args) = @_; 675 my ($cb, @args) = @_;
546 676
547 # we seemingly have to make a local copy of the whole thing, 677 # we seemingly have to make a local copy of the whole thing,
548 # otherwise perl prematurely frees the stuff :/ 678 # otherwise perl prematurely frees the stuff :/
549 # TODO: investigate and fix (likely this will be rather laborious) 679 # TODO: investigate and fix (likely this will be rather laborious)
550 680
551 my @res = Coro::Util::fork_eval { 681 my @res = Coro::Util::fork_eval {
552 reset_signals; 682 cf::post_fork;
553 &$cb 683 &$cb
554 }, @args; 684 } @args;
555 685
556 wantarray ? @res : $res[-1] 686 wantarray ? @res : $res[-1]
687}
688
689sub objinfo {
690 (
691 "counter value" => cf::object::object_count,
692 "objects created" => cf::object::create_count,
693 "objects destroyed" => cf::object::destroy_count,
694 "freelist size" => cf::object::free_count,
695 "allocated objects" => cf::object::objects_size,
696 "active objects" => cf::object::actives_size,
697 )
557} 698}
558 699
559=item $coin = coin_from_name $name 700=item $coin = coin_from_name $name
560 701
561=cut 702=cut
… …
598within each server. 739within each server.
599 740
600=cut 741=cut
601 742
602sub db_table($) { 743sub db_table($) {
744 cf::error "db_get called from main context"
745 if $Coro::current == $Coro::main;
746
603 my ($name) = @_; 747 my ($name) = @_;
604 my $db = BDB::db_create $DB_ENV; 748 my $db = BDB::db_create $DB_ENV;
605 749
606 eval { 750 eval {
607 $db->set_flags (BDB::CHKSUM); 751 $db->set_flags (BDB::CHKSUM);
… …
617} 761}
618 762
619our $DB; 763our $DB;
620 764
621sub db_init { 765sub db_init {
622 cf::sync_job {
623 $DB ||= db_table "db"; 766 $DB ||= db_table "db";
624 };
625} 767}
626 768
627sub db_get($$) { 769sub db_get($$) {
628 my $key = "$_[0]/$_[1]"; 770 my $key = "$_[0]/$_[1]";
629 771
630 cf::sync_job { 772 cf::error "db_get called from main context"
773 if $Coro::current == $Coro::main;
774
631 BDB::db_get $DB, undef, $key, my $data; 775 BDB::db_get $DB, undef, $key, my $data;
632 776
633 $! ? () 777 $! ? ()
634 : $data 778 : $data
635 }
636} 779}
637 780
638sub db_put($$$) { 781sub db_put($$$) {
639 BDB::dbreq_pri 4; 782 BDB::dbreq_pri 4;
640 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 783 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
668 811
669 my @data; 812 my @data;
670 my $md5; 813 my $md5;
671 814
672 for (0 .. $#$src) { 815 for (0 .. $#$src) {
673 0 <= aio_load $src->[$_], $data[$_] 816 $data[$_] = load_file $src->[$_];
674 or Carp::croak "$src->[$_]: $!";
675 } 817 }
676 818
677 # if processing is expensive, check 819 # if processing is expensive, check
678 # checksum first 820 # checksum first
679 if (1) { 821 if (1) {
… …
696 838
697 my $t1 = Time::HiRes::time; 839 my $t1 = Time::HiRes::time;
698 my $data = $process->(\@data); 840 my $data = $process->(\@data);
699 my $t2 = Time::HiRes::time; 841 my $t2 = Time::HiRes::time;
700 842
701 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 843 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
702 844
703 db_put cache => "$id/data", $data; 845 db_put cache => "$id/data", $data;
704 db_put cache => "$id/md5" , $md5; 846 db_put cache => "$id/md5" , $md5;
705 db_put cache => "$id/meta", $meta; 847 db_put cache => "$id/meta", $meta;
706 848
… …
716 858
717=cut 859=cut
718 860
719sub datalog($@) { 861sub datalog($@) {
720 my ($type, %kv) = @_; 862 my ($type, %kv) = @_;
721 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 863 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
722} 864}
723 865
724=back 866=back
725 867
726=cut 868=cut
727 869
728############################################################################# 870#############################################################################
729 871
730=head2 ATTACHABLE OBJECTS 872=head2 ATTACHABLE OBJECTS
731 873
732Many objects in crossfire are so-called attachable objects. That means you can 874Many objects in deliantra are so-called attachable objects. That means you can
733attach callbacks/event handlers (a collection of which is called an "attachment") 875attach callbacks/event handlers (a collection of which is called an "attachment")
734to it. All such attachable objects support the following methods. 876to it. All such attachable objects support the following methods.
735 877
736In the following description, CLASS can be any of C<global>, C<object> 878In the following description, CLASS can be any of C<global>, C<object>
737C<player>, C<client> or C<map> (i.e. the attachable objects in 879C<player>, C<client> or C<map> (i.e. the attachable objects in
… …
787=item cf::CLASS::attachment $name, ... 929=item cf::CLASS::attachment $name, ...
788 930
789Register an attachment by C<$name> through which attachable objects of the 931Register an attachment by C<$name> through which attachable objects of the
790given CLASS can refer to this attachment. 932given CLASS can refer to this attachment.
791 933
792Some classes such as crossfire maps and objects can specify attachments 934Some classes such as deliantra maps and objects can specify attachments
793that are attached at load/instantiate time, thus the need for a name. 935that are attached at load/instantiate time, thus the need for a name.
794 936
795These calls expect any number of the following handler/hook descriptions: 937These calls expect any number of the following handler/hook descriptions:
796 938
797=over 4 939=over 4
… …
921 1063
922 } elsif (exists $cb_id{$type}) { 1064 } elsif (exists $cb_id{$type}) {
923 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1065 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
924 1066
925 } elsif (ref $type) { 1067 } elsif (ref $type) {
926 warn "attaching objects not supported, ignoring.\n"; 1068 error "attaching objects not supported, ignoring.\n";
927 1069
928 } else { 1070 } else {
929 shift @arg; 1071 shift @arg;
930 warn "attach argument '$type' not supported, ignoring.\n"; 1072 error "attach argument '$type' not supported, ignoring.\n";
931 } 1073 }
932 } 1074 }
933} 1075}
934 1076
935sub _object_attach { 1077sub _object_attach {
… …
945 _attach $registry, $klass, @attach; 1087 _attach $registry, $klass, @attach;
946 } 1088 }
947 1089
948 $obj->{$name} = \%arg; 1090 $obj->{$name} = \%arg;
949 } else { 1091 } else {
950 warn "object uses attachment '$name' which is not available, postponing.\n"; 1092 info "object uses attachment '$name' which is not available, postponing.\n";
951 } 1093 }
952 1094
953 $obj->{_attachment}{$name} = undef; 1095 $obj->{_attachment}{$name} = undef;
954} 1096}
955 1097
… …
1014 1156
1015 for (@$callbacks) { 1157 for (@$callbacks) {
1016 eval { &{$_->[1]} }; 1158 eval { &{$_->[1]} };
1017 1159
1018 if ($@) { 1160 if ($@) {
1019 warn "$@";
1020 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1161 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1021 override; 1162 override;
1022 } 1163 }
1023 1164
1024 return 1 if $override; 1165 return 1 if $override;
1025 } 1166 }
… …
1104 for (@$attach) { 1245 for (@$attach) {
1105 my ($klass, @attach) = @$_; 1246 my ($klass, @attach) = @$_;
1106 _attach $registry, $klass, @attach; 1247 _attach $registry, $klass, @attach;
1107 } 1248 }
1108 } else { 1249 } else {
1109 warn "object uses attachment '$name' that is not available, postponing.\n"; 1250 info "object uses attachment '$name' that is not available, postponing.\n";
1110 } 1251 }
1111 } 1252 }
1112} 1253}
1113 1254
1114cf::attachable->attach ( 1255cf::attachable->attach (
… …
1141 my ($filename, $rdata, $objs) = @_; 1282 my ($filename, $rdata, $objs) = @_;
1142 1283
1143 sync_job { 1284 sync_job {
1144 if (length $$rdata) { 1285 if (length $$rdata) {
1145 utf8::decode (my $decname = $filename); 1286 utf8::decode (my $decname = $filename);
1146 warn sprintf "saving %s (%d,%d)\n", 1287 trace sprintf "saving %s (%d,%d)\n",
1147 $decname, length $$rdata, scalar @$objs; 1288 $decname, length $$rdata, scalar @$objs
1289 if $VERBOSE_IO;
1148 1290
1149 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1291 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1150 aio_chmod $fh, SAVE_MODE; 1292 aio_chmod $fh, SAVE_MODE;
1151 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1293 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1152 aio_fsync $fh if $cf::USE_FSYNC; 1294 if ($cf::USE_FSYNC) {
1295 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;
1296 aio_fsync $fh;
1297 }
1153 aio_close $fh; 1298 aio_close $fh;
1154 1299
1155 if (@$objs) { 1300 if (@$objs) {
1156 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1301 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1157 aio_chmod $fh, SAVE_MODE; 1302 aio_chmod $fh, SAVE_MODE;
1158 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1303 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1159 aio_write $fh, 0, (length $data), $data, 0; 1304 aio_write $fh, 0, (length $data), $data, 0;
1160 aio_fsync $fh if $cf::USE_FSYNC; 1305 if ($cf::USE_FSYNC) {
1306 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;
1307 aio_fsync $fh;
1308 }
1161 aio_close $fh; 1309 aio_close $fh;
1162 aio_rename "$filename.pst~", "$filename.pst"; 1310 aio_rename "$filename.pst~", "$filename.pst";
1163 } 1311 }
1164 } else { 1312 } else {
1165 aio_unlink "$filename.pst"; 1313 aio_unlink "$filename.pst";
1166 } 1314 }
1167 1315
1168 aio_rename "$filename~", $filename; 1316 aio_rename "$filename~", $filename;
1317
1318 $filename =~ s%/[^/]+$%%;
1319 aio_pathsync $filename if $cf::USE_FSYNC;
1169 } else { 1320 } else {
1170 warn "FATAL: $filename~: $!\n"; 1321 error "unable to save objects: $filename~: $!\n";
1171 } 1322 }
1172 } else { 1323 } else {
1173 aio_unlink $filename; 1324 aio_unlink $filename;
1174 aio_unlink "$filename.pst"; 1325 aio_unlink "$filename.pst";
1175 } 1326 }
… …
1199 my $st = eval { Coro::Storable::thaw $av }; 1350 my $st = eval { Coro::Storable::thaw $av };
1200 $av = $st->{objs}; 1351 $av = $st->{objs};
1201 } 1352 }
1202 1353
1203 utf8::decode (my $decname = $filename); 1354 utf8::decode (my $decname = $filename);
1204 warn sprintf "loading %s (%d,%d)\n", 1355 trace sprintf "loading %s (%d,%d)\n",
1205 $decname, length $data, scalar @{$av || []}; 1356 $decname, length $data, scalar @{$av || []}
1357 if $VERBOSE_IO;
1206 1358
1207 ($data, $av) 1359 ($data, $av)
1208} 1360}
1209 1361
1210=head2 COMMAND CALLBACKS 1362=head2 COMMAND CALLBACKS
… …
1266 my ($name, $cb) = @_; 1418 my ($name, $cb) = @_;
1267 1419
1268 $EXTICMD{$name} = $cb; 1420 $EXTICMD{$name} = $cb;
1269} 1421}
1270 1422
1423use File::Glob ();
1424
1271cf::player->attach ( 1425cf::player->attach (
1272 on_command => sub { 1426 on_unknown_command => sub {
1273 my ($pl, $name, $params) = @_; 1427 my ($pl, $name, $params) = @_;
1274 1428
1275 my $cb = $COMMAND{$name} 1429 my $cb = $COMMAND{$name}
1276 or return; 1430 or return;
1277 1431
… …
1300 1454
1301 $pl->ext_reply ($reply, @reply) 1455 $pl->ext_reply ($reply, @reply)
1302 if $reply; 1456 if $reply;
1303 1457
1304 } else { 1458 } else {
1305 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1459 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1306 } 1460 }
1307 1461
1308 cf::override; 1462 cf::override;
1309 }, 1463 },
1310); 1464);
1311 1465
1466# "readahead" all extensions
1467sub cache_extensions {
1468 my $grp = IO::AIO::aio_group;
1469
1470 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1471 for (grep /\.ext$/, @{$_[0]}) {
1472 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1473 }
1474 };
1475
1476 $grp
1477}
1478
1312sub load_extensions { 1479sub load_extensions {
1480 info "loading extensions...";
1481
1313 cf::sync_job { 1482 cf::sync_job {
1314 my %todo; 1483 my %todo;
1315 1484
1316 for my $path (<$LIBDIR/*.ext>) { 1485 for my $path (<$LIBDIR/*.ext>) {
1317 next unless -r $path; 1486 next unless -r $path;
… …
1335 1504
1336 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1505 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1337 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1506 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1338 1507
1339 $ext{source} = 1508 $ext{source} =
1340 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1509 "package $pkg; use common::sense;\n"
1341 . "#line 1 \"$path\"\n{\n" 1510 . "#line 1 \"$path\"\n{\n"
1342 . $source 1511 . $source
1343 . "\n};\n1"; 1512 . "\n};\n1";
1344 1513
1345 $todo{$base} = \%ext; 1514 $todo{$base} = \%ext;
1346 } 1515 }
1347 1516
1517 my $pass = 0;
1348 my %done; 1518 my %done;
1349 while (%todo) { 1519 while (%todo) {
1350 my $progress; 1520 my $progress;
1351 1521
1522 ++$pass;
1523
1524 ext:
1352 while (my ($k, $v) = each %todo) { 1525 while (my ($k, $v) = each %todo) {
1353 for (split /,\s*/, $v->{meta}{depends}) { 1526 for (split /,\s*/, $v->{meta}{depends}) {
1354 goto skip 1527 next ext
1355 unless exists $done{$_}; 1528 unless exists $done{$_};
1356 } 1529 }
1357 1530
1358 warn "... loading '$k' into '$v->{pkg}'\n"; 1531 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1359 1532
1360 unless (eval $v->{source}) { 1533 my $active = eval $v->{source};
1534
1535 if (length $@) {
1361 my $msg = $@ ? "$v->{path}: $@\n" 1536 error "$v->{path}: $@\n";
1362 : "$v->{base}: extension inactive.\n";
1363 1537
1364 if (exists $v->{meta}{mandatory}) {
1365 warn $msg;
1366 cf::cleanup "mandatory extension failed to load, exiting."; 1538 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1367 } 1539 if exists $v->{meta}{mandatory};
1368 1540
1369 warn $msg; 1541 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1542 delete $todo{$k};
1543 } else {
1544 $done{$k} = delete $todo{$k};
1545 push @EXTS, $v->{pkg};
1546 $progress = 1;
1547
1548 info "$v->{base}: extension inactive.\n"
1549 unless $active;
1370 } 1550 }
1371
1372 $done{$k} = delete $todo{$k};
1373 push @EXTS, $v->{pkg};
1374 $progress = 1;
1375 } 1551 }
1376 1552
1377 skip: 1553 unless ($progress) {
1378 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1554 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1379 unless $progress; 1555
1556 while (my ($k, $v) = each %todo) {
1557 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1558 if exists $v->{meta}{mandatory};
1559 }
1560
1561 last;
1562 }
1380 } 1563 }
1381 }; 1564 };
1382} 1565}
1383 1566
1384############################################################################# 1567#############################################################################
1385 1568
1386=back 1569=back
1387 1570
1388=head2 CORE EXTENSIONS 1571=head2 CORE EXTENSIONS
1389 1572
1390Functions and methods that extend core crossfire objects. 1573Functions and methods that extend core deliantra objects.
1391 1574
1392=cut 1575=cut
1393 1576
1394package cf::player; 1577package cf::player;
1395 1578
… …
1438 1621
1439sub exists($) { 1622sub exists($) {
1440 my ($login) = @_; 1623 my ($login) = @_;
1441 1624
1442 $cf::PLAYER{$login} 1625 $cf::PLAYER{$login}
1443 or cf::sync_job { !aio_stat path $login } 1626 or !aio_stat path $login
1444} 1627}
1445 1628
1446sub find($) { 1629sub find($) {
1447 return $cf::PLAYER{$_[0]} || do { 1630 return $cf::PLAYER{$_[0]} || do {
1448 my $login = $_[0]; 1631 my $login = $_[0];
… …
1468 $cf::PLAYER{$login} = $pl 1651 $cf::PLAYER{$login} = $pl
1469 } 1652 }
1470 } 1653 }
1471} 1654}
1472 1655
1656cf::player->attach (
1657 on_load => sub {
1658 my ($pl, $path) = @_;
1659
1660 # restore slots saved in save, below
1661 my $slots = delete $pl->{_slots};
1662
1663 $pl->ob->current_weapon ($slots->[0]);
1664 $pl->combat_ob ($slots->[1]);
1665 $pl->ranged_ob ($slots->[2]);
1666 },
1667);
1668
1473sub save($) { 1669sub save($) {
1474 my ($pl) = @_; 1670 my ($pl) = @_;
1475 1671
1476 return if $pl->{deny_save}; 1672 return if $pl->{deny_save};
1477 1673
… …
1482 1678
1483 aio_mkdir playerdir $pl, 0770; 1679 aio_mkdir playerdir $pl, 0770;
1484 $pl->{last_save} = $cf::RUNTIME; 1680 $pl->{last_save} = $cf::RUNTIME;
1485 1681
1486 cf::get_slot 0.01; 1682 cf::get_slot 0.01;
1683
1684 # save slots, to be restored later
1685 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1487 1686
1488 $pl->save_pl ($path); 1687 $pl->save_pl ($path);
1489 cf::cede_to_tick; 1688 cf::cede_to_tick;
1490} 1689}
1491 1690
… …
1525 my $name = $pl->ob->name; 1724 my $name = $pl->ob->name;
1526 1725
1527 $pl->{deny_save} = 1; 1726 $pl->{deny_save} = 1;
1528 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1727 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1529 1728
1530 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1729 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1531 $pl->deactivate; 1730 $pl->deactivate;
1731
1532 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1732 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1533 $pl->ob->check_score;
1534 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1733 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1734 ext::highscore::check ($pl->ob);
1735
1535 $pl->ns->destroy if $pl->ns; 1736 $pl->ns->destroy if $pl->ns;
1536 1737
1537 my $path = playerdir $pl; 1738 my $path = playerdir $pl;
1538 my $temp = "$path~$cf::RUNTIME~deleting~"; 1739 my $temp = "$path~$cf::RUNTIME~deleting~";
1539 aio_rename $path, $temp; 1740 aio_rename $path, $temp;
… …
1593 \@logins 1794 \@logins
1594} 1795}
1595 1796
1596=item $player->maps 1797=item $player->maps
1597 1798
1799=item cf::player::maps $login
1800
1598Returns an arrayref of map paths that are private for this 1801Returns an arrayref of map paths that are private for this
1599player. May block. 1802player. May block.
1600 1803
1601=cut 1804=cut
1602 1805
… …
1619 } 1822 }
1620 1823
1621 \@paths 1824 \@paths
1622} 1825}
1623 1826
1624=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1827=item $protocol_xml = $player->expand_cfpod ($cfpod)
1625 1828
1626Expand crossfire pod fragments into protocol xml. 1829Expand deliantra pod fragments into protocol xml.
1627 1830
1628=item $player->ext_reply ($msgid, @msg) 1831=item $player->ext_reply ($msgid, @msg)
1629 1832
1630Sends an ext reply to the player. 1833Sends an ext reply to the player.
1631 1834
… …
1663 1866
1664=cut 1867=cut
1665 1868
1666sub find_by_path($) { 1869sub find_by_path($) {
1667 my ($path) = @_; 1870 my ($path) = @_;
1871
1872 $path =~ s/^~[^\/]*//; # skip ~login
1668 1873
1669 my ($match, $specificity); 1874 my ($match, $specificity);
1670 1875
1671 for my $region (list) { 1876 for my $region (list) {
1672 if ($region->{match} && $path =~ $region->{match}) { 1877 if ($region->{match} && $path =~ $region->{match}) {
… …
1701sub generate_random_map { 1906sub generate_random_map {
1702 my ($self, $rmp) = @_; 1907 my ($self, $rmp) = @_;
1703 1908
1704 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1909 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1705 1910
1706 # mit "rum" bekleckern, nicht
1707 $self->_create_random_map ( 1911 $self->_create_random_map ($rmp);
1708 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1709 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1710 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1711 $rmp->{exit_on_final_map},
1712 $rmp->{xsize}, $rmp->{ysize},
1713 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1714 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1715 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1716 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1717 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1718 (cf::region::find $rmp->{region}), $rmp->{custom}
1719 )
1720} 1912}
1721 1913
1722=item cf::map->register ($regex, $prio) 1914=item cf::map->register ($regex, $prio)
1723 1915
1724Register a handler for the map path matching the given regex at the 1916Register a handler for the map path matching the given regex at the
… …
1729 1921
1730sub register { 1922sub register {
1731 my (undef, $regex, $prio) = @_; 1923 my (undef, $regex, $prio) = @_;
1732 my $pkg = caller; 1924 my $pkg = caller;
1733 1925
1734 no strict;
1735 push @{"$pkg\::ISA"}, __PACKAGE__; 1926 push @{"$pkg\::ISA"}, __PACKAGE__;
1736 1927
1737 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1928 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1738} 1929}
1739 1930
1740# also paths starting with '/' 1931# also paths starting with '/'
1741$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1932$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1742 1933
1743sub thawer_merge { 1934sub thawer_merge {
1744 my ($self, $merge) = @_; 1935 my ($self, $merge) = @_;
1745 1936
1746 # we have to keep some variables in memory intact 1937 # we have to keep some variables in memory intact
… …
1751} 1942}
1752 1943
1753sub normalise { 1944sub normalise {
1754 my ($path, $base) = @_; 1945 my ($path, $base) = @_;
1755 1946
1756 $path = "$path"; # make sure its a string 1947 $path = "$path"; # make sure it's a string
1757 1948
1758 $path =~ s/\.map$//; 1949 $path =~ s/\.map$//;
1759 1950
1760 # map plan: 1951 # map plan:
1761 # 1952 #
… …
1776 $base =~ s{[^/]+/?$}{}; 1967 $base =~ s{[^/]+/?$}{};
1777 $path = "$base/$path"; 1968 $path = "$base/$path";
1778 } 1969 }
1779 1970
1780 for ($path) { 1971 for ($path) {
1781 redo if s{//}{/};
1782 redo if s{/\.?/}{/}; 1972 redo if s{/\.?/}{/};
1783 redo if s{/[^/]+/\.\./}{/}; 1973 redo if s{/[^/]+/\.\./}{/};
1784 } 1974 }
1785 1975
1786 $path 1976 $path
… …
1800 $self->init; # pass $1 etc. 1990 $self->init; # pass $1 etc.
1801 return $self; 1991 return $self;
1802 } 1992 }
1803 } 1993 }
1804 1994
1805 Carp::cluck "unable to resolve path '$path' (base '$base')."; 1995 Carp::cluck "unable to resolve path '$path' (base '$base')";
1806 () 1996 ()
1807} 1997}
1808 1998
1999# may re-bless or do other evil things
1809sub init { 2000sub init {
1810 my ($self) = @_; 2001 my ($self) = @_;
1811 2002
1812 $self 2003 $self
1813} 2004}
… …
1842sub uniq_path { 2033sub uniq_path {
1843 my ($self) = @_; 2034 my ($self) = @_;
1844 2035
1845 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 2036 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1846 "$UNIQUEDIR/$path" 2037 "$UNIQUEDIR/$path"
1847}
1848
1849# and all this just because we cannot iterate over
1850# all maps in C++...
1851sub change_all_map_light {
1852 my ($change) = @_;
1853
1854 $_->change_map_light ($change)
1855 for grep $_->outdoor, values %cf::MAP;
1856} 2038}
1857 2039
1858sub decay_objects { 2040sub decay_objects {
1859 my ($self) = @_; 2041 my ($self) = @_;
1860 2042
… …
1942 2124
1943sub find; 2125sub find;
1944sub find { 2126sub find {
1945 my ($path, $origin) = @_; 2127 my ($path, $origin) = @_;
1946 2128
2129 cf::cede_to_tick;
2130
1947 $path = normalise $path, $origin && $origin->path; 2131 $path = normalise $path, $origin && $origin->path;
1948 2132
1949 cf::lock_wait "map_data:$path";#d#remove 2133 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1950 cf::lock_wait "map_find:$path"; 2134 my $guard2 = cf::lock_acquire "map_find:$path";
1951 2135
1952 $cf::MAP{$path} || do { 2136 $cf::MAP{$path} || do {
1953 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1954 my $guard2 = cf::lock_acquire "map_find:$path";
1955
1956 my $map = new_from_path cf::map $path 2137 my $map = new_from_path cf::map $path
1957 or return; 2138 or return;
1958 2139
1959 $map->{last_save} = $cf::RUNTIME; 2140 $map->{last_save} = $cf::RUNTIME;
1960 2141
… …
1972 2153
1973 $cf::MAP{$path} = $map 2154 $cf::MAP{$path} = $map
1974 } 2155 }
1975} 2156}
1976 2157
1977sub pre_load { } 2158sub pre_load { }
1978sub post_load { } 2159#sub post_load { } # XS
1979 2160
1980sub load { 2161sub load {
1981 my ($self) = @_; 2162 my ($self) = @_;
1982 2163
1983 local $self->{deny_reset} = 1; # loading can take a long time 2164 local $self->{deny_reset} = 1; # loading can take a long time
… …
2028 unless ($self->{deny_activate}) { 2209 unless ($self->{deny_activate}) {
2029 $self->decay_objects; 2210 $self->decay_objects;
2030 $self->fix_auto_apply; 2211 $self->fix_auto_apply;
2031 $self->update_buttons; 2212 $self->update_buttons;
2032 cf::cede_to_tick; 2213 cf::cede_to_tick;
2033 $self->set_darkness_map;
2034 cf::cede_to_tick;
2035 $self->activate; 2214 $self->activate;
2036 } 2215 }
2037 2216
2038 $self->{last_save} = $cf::RUNTIME; 2217 $self->{last_save} = $cf::RUNTIME;
2039 $self->last_access ($cf::RUNTIME); 2218 $self->last_access ($cf::RUNTIME);
2040 2219
2041 $self->in_memory (cf::MAP_ACTIVE); 2220 $self->in_memory (cf::MAP_ACTIVE);
2042 } 2221 }
2043 2222
2044 $self->post_load; 2223 $self->post_load;
2045}
2046 2224
2225 1
2226}
2227
2228# customize the map for a given player, i.e.
2229# return the _real_ map. used by e.g. per-player
2230# maps to change the path to ~playername/mappath
2047sub customise_for { 2231sub customise_for {
2048 my ($self, $ob) = @_; 2232 my ($self, $ob) = @_;
2049 2233
2050 return find "~" . $ob->name . "/" . $self->{path} 2234 return find "~" . $ob->name . "/" . $self->{path}
2051 if $self->per_player; 2235 if $self->per_player;
… …
2067 or next; 2251 or next;
2068 $neigh = find $neigh, $map 2252 $neigh = find $neigh, $map
2069 or next; 2253 or next;
2070 $neigh->load; 2254 $neigh->load;
2071 2255
2256 # now find the diagonal neighbours
2072 push @neigh, 2257 push @neigh,
2073 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2258 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2074 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2259 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2075 } 2260 }
2076 2261
… …
2083} 2268}
2084 2269
2085sub find_sync { 2270sub find_sync {
2086 my ($path, $origin) = @_; 2271 my ($path, $origin) = @_;
2087 2272
2088 cf::sync_job { find $path, $origin } 2273 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2274 if $Coro::current == $Coro::main;
2275
2276 find $path, $origin
2089} 2277}
2090 2278
2091sub do_load_sync { 2279sub do_load_sync {
2092 my ($map) = @_; 2280 my ($map) = @_;
2093 2281
2094 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2282 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2095 if $Coro::current == $Coro::main; 2283 if $Coro::current == $Coro::main;
2096 2284
2097 cf::sync_job { $map->load }; 2285 $map->load;
2098} 2286}
2099 2287
2100our %MAP_PREFETCH; 2288our %MAP_PREFETCH;
2101our $MAP_PREFETCHER = undef; 2289our $MAP_PREFETCHER = undef;
2102 2290
… …
2128 $MAP_PREFETCHER->prio (6); 2316 $MAP_PREFETCHER->prio (6);
2129 2317
2130 () 2318 ()
2131} 2319}
2132 2320
2321# common code, used by both ->save and ->swapout
2133sub save { 2322sub _save {
2134 my ($self) = @_; 2323 my ($self) = @_;
2135
2136 my $lock = cf::lock_acquire "map_data:$self->{path}";
2137 2324
2138 $self->{last_save} = $cf::RUNTIME; 2325 $self->{last_save} = $cf::RUNTIME;
2139 2326
2140 return unless $self->dirty; 2327 return unless $self->dirty;
2141 2328
… …
2161 } else { 2348 } else {
2162 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2349 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2163 } 2350 }
2164} 2351}
2165 2352
2353sub save {
2354 my ($self) = @_;
2355
2356 my $lock = cf::lock_acquire "map_data:$self->{path}";
2357
2358 $self->_save;
2359}
2360
2166sub swap_out { 2361sub swap_out {
2167 my ($self) = @_; 2362 my ($self) = @_;
2168 2363
2169 # save first because save cedes
2170 $self->save;
2171
2172 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2364 my $lock = cf::lock_acquire "map_data:$self->{path}";
2173 2365
2174 return if $self->players;
2175 return if $self->in_memory != cf::MAP_ACTIVE; 2366 return if $self->in_memory != cf::MAP_ACTIVE;
2176 return if $self->{deny_save}; 2367 return if $self->{deny_save};
2368 return if $self->players;
2177 2369
2370 # first deactivate the map and "unlink" it from the core
2371 $self->deactivate;
2372 $_->clear_links_to ($self) for values %cf::MAP;
2178 $self->in_memory (cf::MAP_SWAPPED); 2373 $self->in_memory (cf::MAP_SWAPPED);
2374
2375 # then atomically save
2376 $self->_save;
2377
2378 # then free the map
2379 $self->clear;
2380}
2381
2382sub reset_at {
2383 my ($self) = @_;
2384
2385 # TODO: safety, remove and allow resettable per-player maps
2386 return 1e99 if $self->{deny_reset};
2387
2388 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2389 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2390
2391 $time + $to
2392}
2393
2394sub should_reset {
2395 my ($self) = @_;
2396
2397 $self->reset_at <= $cf::RUNTIME
2398}
2399
2400sub reset {
2401 my ($self) = @_;
2402
2403 my $lock = cf::lock_acquire "map_data:$self->{path}";
2404
2405 return if $self->players;
2406
2407 cf::trace "resetting map ", $self->path, "\n";
2408
2409 $self->in_memory (cf::MAP_SWAPPED);
2410
2411 # need to save uniques path
2412 unless ($self->{deny_save}) {
2413 my $uniq = $self->uniq_path; utf8::encode $uniq;
2414
2415 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2416 if $uniq;
2417 }
2418
2419 delete $cf::MAP{$self->path};
2179 2420
2180 $self->deactivate; 2421 $self->deactivate;
2181 $_->clear_links_to ($self) for values %cf::MAP; 2422 $_->clear_links_to ($self) for values %cf::MAP;
2182 $self->clear; 2423 $self->clear;
2183}
2184
2185sub reset_at {
2186 my ($self) = @_;
2187
2188 # TODO: safety, remove and allow resettable per-player maps
2189 return 1e99 if $self->{deny_reset};
2190
2191 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2192 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2193
2194 $time + $to
2195}
2196
2197sub should_reset {
2198 my ($self) = @_;
2199
2200 $self->reset_at <= $cf::RUNTIME
2201}
2202
2203sub reset {
2204 my ($self) = @_;
2205
2206 my $lock = cf::lock_acquire "map_data:$self->{path}";
2207
2208 return if $self->players;
2209
2210 warn "resetting map ", $self->path;
2211
2212 $self->in_memory (cf::MAP_SWAPPED);
2213
2214 # need to save uniques path
2215 unless ($self->{deny_save}) {
2216 my $uniq = $self->uniq_path; utf8::encode $uniq;
2217
2218 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2219 if $uniq;
2220 }
2221
2222 delete $cf::MAP{$self->path};
2223
2224 $self->deactivate;
2225 $_->clear_links_to ($self) for values %cf::MAP;
2226 $self->clear;
2227 2424
2228 $self->unlink_save; 2425 $self->unlink_save;
2229 $self->destroy; 2426 $self->destroy;
2230} 2427}
2231 2428
… …
2239 2436
2240 delete $cf::MAP{$self->path}; 2437 delete $cf::MAP{$self->path};
2241 2438
2242 $self->unlink_save; 2439 $self->unlink_save;
2243 2440
2244 bless $self, "cf::map"; 2441 bless $self, "cf::map::wrap";
2245 delete $self->{deny_reset}; 2442 delete $self->{deny_reset};
2246 $self->{deny_save} = 1; 2443 $self->{deny_save} = 1;
2247 $self->reset_timeout (1); 2444 $self->reset_timeout (1);
2248 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2445 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2249 2446
… …
2306 : normalise $_ 2503 : normalise $_
2307 } @{ aio_readdir $UNIQUEDIR or [] } 2504 } @{ aio_readdir $UNIQUEDIR or [] }
2308 ] 2505 ]
2309} 2506}
2310 2507
2508=item cf::map::static_maps
2509
2510Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2511file in the shared directory excluding F</styles> and F</editor>). May
2512block.
2513
2514=cut
2515
2516sub static_maps() {
2517 my @dirs = "";
2518 my @maps;
2519
2520 while (@dirs) {
2521 my $dir = shift @dirs;
2522
2523 next if $dir eq "/styles" || $dir eq "/editor";
2524
2525 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2526 or return;
2527
2528 for (@$files) {
2529 s/\.map$// or next;
2530 utf8::decode $_;
2531 push @maps, "$dir/$_";
2532 }
2533
2534 push @dirs, map "$dir/$_", @$dirs;
2535 }
2536
2537 \@maps
2538}
2539
2311=back 2540=back
2312 2541
2313=head3 cf::object 2542=head3 cf::object
2314 2543
2315=cut 2544=cut
… …
2380 2609
2381our $SAY_CHANNEL = { 2610our $SAY_CHANNEL = {
2382 id => "say", 2611 id => "say",
2383 title => "Map", 2612 title => "Map",
2384 reply => "say ", 2613 reply => "say ",
2385 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2614 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2386}; 2615};
2387 2616
2388our $CHAT_CHANNEL = { 2617our $CHAT_CHANNEL = {
2389 id => "chat", 2618 id => "chat",
2390 title => "Chat", 2619 title => "Chat",
… …
2445 2674
2446=item $player_object->enter_link 2675=item $player_object->enter_link
2447 2676
2448Freezes the player and moves him/her to a special map (C<{link}>). 2677Freezes the player and moves him/her to a special map (C<{link}>).
2449 2678
2450The player should be reasonably safe there for short amounts of time. You 2679The player should be reasonably safe there for short amounts of time (e.g.
2451I<MUST> call C<leave_link> as soon as possible, though. 2680for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2681though, as the player cannot control the character while it is on the link
2682map.
2452 2683
2453Will never block. 2684Will never block.
2454 2685
2455=item $player_object->leave_link ($map, $x, $y) 2686=item $player_object->leave_link ($map, $x, $y)
2456 2687
… …
2476sub cf::object::player::enter_link { 2707sub cf::object::player::enter_link {
2477 my ($self) = @_; 2708 my ($self) = @_;
2478 2709
2479 $self->deactivate_recursive; 2710 $self->deactivate_recursive;
2480 2711
2712 ++$self->{_link_recursion};
2713
2481 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2714 return if UNIVERSAL::isa $self->map, "ext::map_link";
2482 2715
2483 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2716 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2484 if $self->map && $self->map->{path} ne "{link}"; 2717 if $self->map && $self->map->{path} ne "{link}";
2485 2718
2486 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2719 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2487} 2720}
2488 2721
2489sub cf::object::player::leave_link { 2722sub cf::object::player::leave_link {
2490 my ($self, $map, $x, $y) = @_; 2723 my ($self, $map, $x, $y) = @_;
2491 2724
… …
2508 ($x, $y) = (-1, -1) 2741 ($x, $y) = (-1, -1)
2509 unless (defined $x) && (defined $y); 2742 unless (defined $x) && (defined $y);
2510 2743
2511 # use -1 or undef as default coordinates, not 0, 0 2744 # use -1 or undef as default coordinates, not 0, 0
2512 ($x, $y) = ($map->enter_x, $map->enter_y) 2745 ($x, $y) = ($map->enter_x, $map->enter_y)
2513 if $x <=0 && $y <= 0; 2746 if $x <= 0 && $y <= 0;
2514 2747
2515 $map->load; 2748 $map->load;
2516 $map->load_neighbours; 2749 $map->load_neighbours;
2517 2750
2518 return unless $self->contr->active; 2751 return unless $self->contr->active;
2519 $self->activate_recursive;
2520 2752
2521 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2753 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2522 $self->enter_map ($map, $x, $y); 2754 if ($self->enter_map ($map, $x, $y)) {
2523} 2755 # entering was successful
2756 delete $self->{_link_recursion};
2757 # only activate afterwards, to support waiting in hooks
2758 $self->activate_recursive;
2759 }
2524 2760
2761}
2762
2525=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2763=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2526 2764
2527Moves the player to the given map-path and coordinates by first freezing 2765Moves the player to the given map-path and coordinates by first freezing
2528her, loading and preparing them map, calling the provided $check callback 2766her, loading and preparing them map, calling the provided $check callback
2529that has to return the map if sucecssful, and then unfreezes the player on 2767that has to return the map if sucecssful, and then unfreezes the player on
2530the new (success) or old (failed) map position. In either case, $done will 2768the new (success) or old (failed) map position. In either case, $done will
… …
2537 2775
2538our $GOTOGEN; 2776our $GOTOGEN;
2539 2777
2540sub cf::object::player::goto { 2778sub cf::object::player::goto {
2541 my ($self, $path, $x, $y, $check, $done) = @_; 2779 my ($self, $path, $x, $y, $check, $done) = @_;
2780
2781 if ($self->{_link_recursion} >= $MAX_LINKS) {
2782 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2783 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2784 ($path, $x, $y) = @$EMERGENCY_POSITION;
2785 }
2542 2786
2543 # do generation counting so two concurrent goto's will be executed in-order 2787 # do generation counting so two concurrent goto's will be executed in-order
2544 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2788 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2545 2789
2546 $self->enter_link; 2790 $self->enter_link;
… …
2570 my $map = eval { 2814 my $map = eval {
2571 my $map = defined $path ? cf::map::find $path : undef; 2815 my $map = defined $path ? cf::map::find $path : undef;
2572 2816
2573 if ($map) { 2817 if ($map) {
2574 $map = $map->customise_for ($self); 2818 $map = $map->customise_for ($self);
2575 $map = $check->($map) if $check && $map; 2819 $map = $check->($map, $x, $y, $self) if $check && $map;
2576 } else { 2820 } else {
2577 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2821 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2578 } 2822 }
2579 2823
2580 $map 2824 $map
… …
2588 if ($gen == $self->{_goto_generation}) { 2832 if ($gen == $self->{_goto_generation}) {
2589 delete $self->{_goto_generation}; 2833 delete $self->{_goto_generation};
2590 $self->leave_link ($map, $x, $y); 2834 $self->leave_link ($map, $x, $y);
2591 } 2835 }
2592 2836
2593 $done->() if $done; 2837 $done->($self) if $done;
2594 })->prio (1); 2838 })->prio (1);
2595} 2839}
2596 2840
2597=item $player_object->enter_exit ($exit_object) 2841=item $player_object->enter_exit ($exit_object)
2598 2842
… …
2686 $self->contr->savebed ($map, $x, $y) 2930 $self->contr->savebed ($map, $x, $y)
2687 if $exit->flag (cf::FLAG_DAMNED); 2931 if $exit->flag (cf::FLAG_DAMNED);
2688 2932
2689 1 2933 1
2690 }) { 2934 }) {
2691 $self->message ("Something went wrong deep within the crossfire server. " 2935 $self->message ("Something went wrong deep within the deliantra server. "
2692 . "I'll try to bring you back to the map you were before. " 2936 . "I'll try to bring you back to the map you were before. "
2693 . "Please report this to the dungeon master!", 2937 . "Please report this to the dungeon master!",
2694 cf::NDI_UNIQUE | cf::NDI_RED); 2938 cf::NDI_UNIQUE | cf::NDI_RED);
2695 2939
2696 warn "ERROR in enter_exit: $@"; 2940 error "ERROR in enter_exit: $@";
2697 $self->leave_link; 2941 $self->leave_link;
2698 } 2942 }
2699 })->prio (1); 2943 })->prio (1);
2700} 2944}
2701 2945
… …
2713sub cf::client::send_drawinfo { 2957sub cf::client::send_drawinfo {
2714 my ($self, $text, $flags) = @_; 2958 my ($self, $text, $flags) = @_;
2715 2959
2716 utf8::encode $text; 2960 utf8::encode $text;
2717 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2961 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2962}
2963
2964=item $client->send_big_packet ($pkt)
2965
2966Like C<send_packet>, but tries to compress large packets, and fragments
2967them as required.
2968
2969=cut
2970
2971our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2972
2973sub cf::client::send_big_packet {
2974 my ($self, $pkt) = @_;
2975
2976 # try lzf for large packets
2977 $pkt = "lzf " . Compress::LZF::compress $pkt
2978 if 1024 <= length $pkt and $self->{can_lzf};
2979
2980 # split very large packets
2981 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2982 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2983 $pkt = "frag";
2984 }
2985
2986 $self->send_packet ($pkt);
2718} 2987}
2719 2988
2720=item $client->send_msg ($channel, $msg, $color, [extra...]) 2989=item $client->send_msg ($channel, $msg, $color, [extra...])
2721 2990
2722Send a drawinfo or msg packet to the client, formatting the msg for the 2991Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2726 2995
2727=cut 2996=cut
2728 2997
2729# non-persistent channels (usually the info channel) 2998# non-persistent channels (usually the info channel)
2730our %CHANNEL = ( 2999our %CHANNEL = (
3000 "c/motd" => {
3001 id => "infobox",
3002 title => "MOTD",
3003 reply => undef,
3004 tooltip => "The message of the day",
3005 },
2731 "c/identify" => { 3006 "c/identify" => {
2732 id => "infobox", 3007 id => "infobox",
2733 title => "Identify", 3008 title => "Identify",
2734 reply => undef, 3009 reply => undef,
2735 tooltip => "Items recently identified", 3010 tooltip => "Items recently identified",
… …
2737 "c/examine" => { 3012 "c/examine" => {
2738 id => "infobox", 3013 id => "infobox",
2739 title => "Examine", 3014 title => "Examine",
2740 reply => undef, 3015 reply => undef,
2741 tooltip => "Signs and other items you examined", 3016 tooltip => "Signs and other items you examined",
3017 },
3018 "c/shopinfo" => {
3019 id => "infobox",
3020 title => "Shop Info",
3021 reply => undef,
3022 tooltip => "What your bargaining skill tells you about the shop",
2742 }, 3023 },
2743 "c/book" => { 3024 "c/book" => {
2744 id => "infobox", 3025 id => "infobox",
2745 title => "Book", 3026 title => "Book",
2746 reply => undef, 3027 reply => undef,
… …
2762 id => "infobox", 3043 id => "infobox",
2763 title => "Body Parts", 3044 title => "Body Parts",
2764 reply => undef, 3045 reply => undef,
2765 tooltip => "Shows which body parts you posess and are available", 3046 tooltip => "Shows which body parts you posess and are available",
2766 }, 3047 },
3048 "c/statistics" => {
3049 id => "infobox",
3050 title => "Statistics",
3051 reply => undef,
3052 tooltip => "Shows your primary statistics",
3053 },
3054 "c/skills" => {
3055 id => "infobox",
3056 title => "Skills",
3057 reply => undef,
3058 tooltip => "Shows your experience per skill and item power",
3059 },
3060 "c/shopitems" => {
3061 id => "infobox",
3062 title => "Shop Items",
3063 reply => undef,
3064 tooltip => "Shows the items currently for sale in this shop",
3065 },
3066 "c/resistances" => {
3067 id => "infobox",
3068 title => "Resistances",
3069 reply => undef,
3070 tooltip => "Shows your resistances",
3071 },
3072 "c/pets" => {
3073 id => "infobox",
3074 title => "Pets",
3075 reply => undef,
3076 tooltip => "Shows information abotu your pets/a specific pet",
3077 },
3078 "c/perceiveself" => {
3079 id => "infobox",
3080 title => "Perceive Self",
3081 reply => undef,
3082 tooltip => "You gained detailed knowledge about yourself",
3083 },
2767 "c/uptime" => { 3084 "c/uptime" => {
2768 id => "infobox", 3085 id => "infobox",
2769 title => "Uptime", 3086 title => "Uptime",
2770 reply => undef, 3087 reply => undef,
2771 tooltip => "How long the server has been running since last restart", 3088 tooltip => "How long the server has been running since last restart",
… …
2780 id => "party", 3097 id => "party",
2781 title => "Party", 3098 title => "Party",
2782 reply => "gsay ", 3099 reply => "gsay ",
2783 tooltip => "Messages and chat related to your party", 3100 tooltip => "Messages and chat related to your party",
2784 }, 3101 },
3102 "c/death" => {
3103 id => "death",
3104 title => "Death",
3105 reply => undef,
3106 tooltip => "Reason for and more info about your most recent death",
3107 },
3108 "c/say" => $SAY_CHANNEL,
3109 "c/chat" => $CHAT_CHANNEL,
2785); 3110);
2786 3111
2787sub cf::client::send_msg { 3112sub cf::client::send_msg {
2788 my ($self, $channel, $msg, $color, @extra) = @_; 3113 my ($self, $channel, $msg, $color, @extra) = @_;
2789 3114
2790 $msg = $self->pl->expand_cfpod ($msg); 3115 $msg = $self->pl->expand_cfpod ($msg)
3116 unless $color & cf::NDI_VERBATIM;
2791 3117
2792 $color &= cf::NDI_CLIENT_MASK; # just in case... 3118 $color &= cf::NDI_CLIENT_MASK; # just in case...
2793 3119
2794 # check predefined channels, for the benefit of C 3120 # check predefined channels, for the benefit of C
2795 if ($CHANNEL{$channel}) { 3121 if ($CHANNEL{$channel}) {
2796 $channel = $CHANNEL{$channel}; 3122 $channel = $CHANNEL{$channel};
2797 3123
2798 $self->ext_msg (channel_info => $channel) 3124 $self->ext_msg (channel_info => $channel);
2799 if $self->can_msg;
2800
2801 $channel = $channel->{id}; 3125 $channel = $channel->{id};
2802 3126
2803 } elsif (ref $channel) { 3127 } elsif (ref $channel) {
2804 # send meta info to client, if not yet sent 3128 # send meta info to client, if not yet sent
2805 unless (exists $self->{channel}{$channel->{id}}) { 3129 unless (exists $self->{channel}{$channel->{id}}) {
2806 $self->{channel}{$channel->{id}} = $channel; 3130 $self->{channel}{$channel->{id}} = $channel;
2807 $self->ext_msg (channel_info => $channel) 3131 $self->ext_msg (channel_info => $channel);
2808 if $self->can_msg;
2809 } 3132 }
2810 3133
2811 $channel = $channel->{id}; 3134 $channel = $channel->{id};
2812 } 3135 }
2813 3136
2814 return unless @extra || length $msg; 3137 return unless @extra || length $msg;
2815 3138
2816 if ($self->can_msg) {
2817 # default colour, mask it out 3139 # default colour, mask it out
2818 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3140 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2819 if $color & cf::NDI_DEF; 3141 if $color & cf::NDI_DEF;
2820 3142
2821 my $pkt = "msg " 3143 my $pkt = "msg "
2822 . $self->{json_coder}->encode ( 3144 . $self->{json_coder}->encode (
2823 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3145 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2824 ); 3146 );
2825 3147
2826 # try lzf for large packets
2827 $pkt = "lzf " . Compress::LZF::compress $pkt
2828 if 1024 <= length $pkt and $self->{can_lzf};
2829
2830 # split very large packets
2831 if (8192 < length $pkt and $self->{can_lzf}) {
2832 $self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2833 $pkt = "frag";
2834 }
2835
2836 $self->send_packet ($pkt); 3148 $self->send_big_packet ($pkt);
2837 } else {
2838 if ($color >= 0) {
2839 # replace some tags by gcfclient-compatible ones
2840 for ($msg) {
2841 1 while
2842 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2843 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2844 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2845 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2846 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2847 }
2848
2849 $color &= cf::NDI_COLOR_MASK;
2850
2851 utf8::encode $msg;
2852
2853 if (0 && $msg =~ /\[/) {
2854 # COMMAND/INFO
2855 $self->send_packet ("drawextinfo $color 10 8 $msg")
2856 } else {
2857 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2858 $self->send_packet ("drawinfo $color $msg")
2859 }
2860 }
2861 }
2862} 3149}
2863 3150
2864=item $client->ext_msg ($type, @msg) 3151=item $client->ext_msg ($type, @msg)
2865 3152
2866Sends an ext event to the client. 3153Sends an ext event to the client.
… …
2869 3156
2870sub cf::client::ext_msg($$@) { 3157sub cf::client::ext_msg($$@) {
2871 my ($self, $type, @msg) = @_; 3158 my ($self, $type, @msg) = @_;
2872 3159
2873 if ($self->extcmd == 2) { 3160 if ($self->extcmd == 2) {
2874 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3161 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2875 } elsif ($self->extcmd == 1) { # TODO: remove 3162 } elsif ($self->extcmd == 1) { # TODO: remove
2876 push @msg, msgtype => "event_$type"; 3163 push @msg, msgtype => "event_$type";
2877 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3164 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2878 } 3165 }
2879} 3166}
2880 3167
2881=item $client->ext_reply ($msgid, @msg) 3168=item $client->ext_reply ($msgid, @msg)
2882 3169
… …
2886 3173
2887sub cf::client::ext_reply($$@) { 3174sub cf::client::ext_reply($$@) {
2888 my ($self, $id, @msg) = @_; 3175 my ($self, $id, @msg) = @_;
2889 3176
2890 if ($self->extcmd == 2) { 3177 if ($self->extcmd == 2) {
2891 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3178 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2892 } elsif ($self->extcmd == 1) { 3179 } elsif ($self->extcmd == 1) {
2893 #TODO: version 1, remove 3180 #TODO: version 1, remove
2894 unshift @msg, msgtype => "reply", msgid => $id; 3181 unshift @msg, msgtype => "reply", msgid => $id;
2895 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3182 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2896 } 3183 }
2897} 3184}
2898 3185
2899=item $success = $client->query ($flags, "text", \&cb) 3186=item $success = $client->query ($flags, "text", \&cb)
2900 3187
… …
2971 3258
2972 $ns->ext_reply ($reply, @reply) 3259 $ns->ext_reply ($reply, @reply)
2973 if $reply; 3260 if $reply;
2974 3261
2975 } else { 3262 } else {
2976 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3263 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2977 } 3264 }
2978 3265
2979 cf::override; 3266 cf::override;
2980 }, 3267 },
2981); 3268);
… …
3001 3288
3002 $coro 3289 $coro
3003} 3290}
3004 3291
3005cf::client->attach ( 3292cf::client->attach (
3006 on_destroy => sub { 3293 on_client_destroy => sub {
3007 my ($ns) = @_; 3294 my ($ns) = @_;
3008 3295
3009 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3296 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3010 }, 3297 },
3011); 3298);
… …
3027our $safe_hole = new Safe::Hole; 3314our $safe_hole = new Safe::Hole;
3028 3315
3029$SIG{FPE} = 'IGNORE'; 3316$SIG{FPE} = 'IGNORE';
3030 3317
3031$safe->permit_only (Opcode::opset qw( 3318$safe->permit_only (Opcode::opset qw(
3032 :base_core :base_mem :base_orig :base_math 3319 :base_core :base_mem :base_orig :base_math :base_loop
3033 grepstart grepwhile mapstart mapwhile 3320 grepstart grepwhile mapstart mapwhile
3034 sort time 3321 sort time
3035)); 3322));
3036 3323
3037# here we export the classes and methods available to script code 3324# here we export the classes and methods available to script code
… …
3041The following functions and methods are available within a safe environment: 3328The following functions and methods are available within a safe environment:
3042 3329
3043 cf::object 3330 cf::object
3044 contr pay_amount pay_player map x y force_find force_add destroy 3331 contr pay_amount pay_player map x y force_find force_add destroy
3045 insert remove name archname title slaying race decrease split 3332 insert remove name archname title slaying race decrease split
3333 value
3046 3334
3047 cf::object::player 3335 cf::object::player
3048 player 3336 player
3049 3337
3050 cf::player 3338 cf::player
… …
3056=cut 3344=cut
3057 3345
3058for ( 3346for (
3059 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3347 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3060 insert remove inv nrof name archname title slaying race 3348 insert remove inv nrof name archname title slaying race
3061 decrease split destroy change_exp)], 3349 decrease split destroy change_exp value msg lore send_msg)],
3062 ["cf::object::player" => qw(player)], 3350 ["cf::object::player" => qw(player)],
3063 ["cf::player" => qw(peaceful)], 3351 ["cf::player" => qw(peaceful send_msg)],
3064 ["cf::map" => qw(trigger)], 3352 ["cf::map" => qw(trigger)],
3065) { 3353) {
3066 no strict 'refs';
3067 my ($pkg, @funs) = @$_; 3354 my ($pkg, @funs) = @$_;
3068 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3355 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3069 for @funs; 3356 for @funs;
3070} 3357}
3071 3358
… …
3086 3373
3087 my $qcode = $code; 3374 my $qcode = $code;
3088 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3375 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3089 $qcode =~ s/\n/\\n/g; 3376 $qcode =~ s/\n/\\n/g;
3090 3377
3378 %vars = (_dummy => 0) unless %vars;
3379
3380 my @res;
3091 local $_; 3381 local $_;
3092 local @safe::cf::_safe_eval_args = values %vars;
3093 3382
3094 my $eval = 3383 my $eval =
3095 "do {\n" 3384 "do {\n"
3096 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3385 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3097 . "#line 0 \"{$qcode}\"\n" 3386 . "#line 0 \"{$qcode}\"\n"
3098 . $code 3387 . $code
3099 . "\n}" 3388 . "\n}"
3100 ; 3389 ;
3101 3390
3391 if ($CFG{safe_eval}) {
3102 sub_generation_inc; 3392 sub_generation_inc;
3393 local @safe::cf::_safe_eval_args = values %vars;
3103 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3394 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3104 sub_generation_inc; 3395 sub_generation_inc;
3396 } else {
3397 local @cf::_safe_eval_args = values %vars;
3398 @res = wantarray ? eval eval : scalar eval $eval;
3399 }
3105 3400
3106 if ($@) { 3401 if ($@) {
3107 warn "$@"; 3402 warn "$@",
3108 warn "while executing safe code '$code'\n"; 3403 "while executing safe code '$code'\n",
3109 warn "with arguments " . (join " ", %vars) . "\n"; 3404 "with arguments " . (join " ", %vars) . "\n";
3110 } 3405 }
3111 3406
3112 wantarray ? @res : $res[0] 3407 wantarray ? @res : $res[0]
3113} 3408}
3114 3409
… …
3128=cut 3423=cut
3129 3424
3130sub register_script_function { 3425sub register_script_function {
3131 my ($fun, $cb) = @_; 3426 my ($fun, $cb) = @_;
3132 3427
3133 no strict 'refs'; 3428 $fun = "safe::$fun" if $CFG{safe_eval};
3134 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3429 *$fun = $safe_hole->wrap ($cb);
3135} 3430}
3136 3431
3137=back 3432=back
3138 3433
3139=cut 3434=cut
… …
3148 # for this (global event?) 3443 # for this (global event?)
3149 %ext::player_env::MUSIC_FACE_CACHE = (); 3444 %ext::player_env::MUSIC_FACE_CACHE = ();
3150 3445
3151 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3446 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3152 3447
3153 warn "loading facedata from $path\n"; 3448 trace "loading facedata from $path\n";
3154 3449
3155 my $facedata; 3450 my $facedata = decode_storable load_file $path;
3156 0 < aio_load $path, $facedata
3157 or die "$path: $!";
3158
3159 $facedata = Coro::Storable::thaw $facedata;
3160 3451
3161 $facedata->{version} == 2 3452 $facedata->{version} == 2
3162 or cf::cleanup "$path: version mismatch, cannot proceed."; 3453 or cf::cleanup "$path: version mismatch, cannot proceed.";
3163 3454
3164 # patch in the exptable 3455 # patch in the exptable
3456 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3165 $facedata->{resource}{"res/exp_table"} = { 3457 $facedata->{resource}{"res/exp_table"} = {
3166 type => FT_RSRC, 3458 type => FT_RSRC,
3167 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3459 data => $exp_table,
3460 hash => (Digest::MD5::md5 $exp_table),
3168 }; 3461 };
3169 cf::cede_to_tick; 3462 cf::cede_to_tick;
3170 3463
3171 { 3464 {
3172 my $faces = $facedata->{faceinfo}; 3465 my $faces = $facedata->{faceinfo};
… …
3174 while (my ($face, $info) = each %$faces) { 3467 while (my ($face, $info) = each %$faces) {
3175 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3468 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3176 3469
3177 cf::face::set_visibility $idx, $info->{visibility}; 3470 cf::face::set_visibility $idx, $info->{visibility};
3178 cf::face::set_magicmap $idx, $info->{magicmap}; 3471 cf::face::set_magicmap $idx, $info->{magicmap};
3179 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3472 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3180 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3473 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3474 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3181 3475
3182 cf::cede_to_tick; 3476 cf::cede_to_tick;
3183 } 3477 }
3184 3478
3185 while (my ($face, $info) = each %$faces) { 3479 while (my ($face, $info) = each %$faces) {
… …
3190 3484
3191 if (my $smooth = cf::face::find $info->{smooth}) { 3485 if (my $smooth = cf::face::find $info->{smooth}) {
3192 cf::face::set_smooth $idx, $smooth; 3486 cf::face::set_smooth $idx, $smooth;
3193 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3487 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3194 } else { 3488 } else {
3195 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3489 error "smooth face '$info->{smooth}' not found for face '$face'";
3196 } 3490 }
3197 3491
3198 cf::cede_to_tick; 3492 cf::cede_to_tick;
3199 } 3493 }
3200 } 3494 }
… …
3209 3503
3210 cf::anim::invalidate_all; # d'oh 3504 cf::anim::invalidate_all; # d'oh
3211 } 3505 }
3212 3506
3213 { 3507 {
3214 # TODO: for gcfclient pleasure, we should give resources
3215 # that gcfclient doesn't grok a >10000 face index.
3216 my $res = $facedata->{resource}; 3508 my $res = $facedata->{resource};
3217 3509
3218 while (my ($name, $info) = each %$res) { 3510 while (my ($name, $info) = each %$res) {
3219 if (defined $info->{type}) { 3511 if (defined $info->{type}) {
3220 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3512 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3221 my $data;
3222 3513
3223 if ($info->{type} & 1) { 3514 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3224 # prepend meta info
3225
3226 my $meta = $enc->encode ({
3227 name => $name,
3228 %{ $info->{meta} || {} },
3229 });
3230
3231 $data = pack "(w/a*)*", $meta, $info->{data};
3232 } else {
3233 $data = $info->{data};
3234 }
3235
3236 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3237 cf::face::set_type $idx, $info->{type}; 3515 cf::face::set_type $idx, $info->{type};
3238 } else { 3516 } else {
3239 $RESOURCE{$name} = $info; 3517 $RESOURCE{$name} = $info; # unused
3240 } 3518 }
3241 3519
3242 cf::cede_to_tick; 3520 cf::cede_to_tick;
3243 } 3521 }
3244 } 3522 }
3245 3523
3246 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3524 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3247 3525
3248 1 3526 1
3249} 3527}
3250
3251cf::global->attach (on_resource_update => sub {
3252 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3253 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3254
3255 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3256 my $sound = $soundconf->{compat}[$_]
3257 or next;
3258
3259 my $face = cf::face::find "sound/$sound->[1]";
3260 cf::sound::set $sound->[0] => $face;
3261 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3262 }
3263
3264 while (my ($k, $v) = each %{$soundconf->{event}}) {
3265 my $face = cf::face::find "sound/$v";
3266 cf::sound::set $k => $face;
3267 }
3268 }
3269});
3270 3528
3271register_exticmd fx_want => sub { 3529register_exticmd fx_want => sub {
3272 my ($ns, $want) = @_; 3530 my ($ns, $want) = @_;
3273 3531
3274 while (my ($k, $v) = each %$want) { 3532 while (my ($k, $v) = each %$want) {
… …
3313sub reload_treasures { 3571sub reload_treasures {
3314 load_resource_file "$DATADIR/treasures" 3572 load_resource_file "$DATADIR/treasures"
3315 or die "unable to load treasurelists\n"; 3573 or die "unable to load treasurelists\n";
3316} 3574}
3317 3575
3576sub reload_sound {
3577 trace "loading sound config from $DATADIR/sound\n";
3578
3579 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3580
3581 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3582 my $sound = $soundconf->{compat}[$_]
3583 or next;
3584
3585 my $face = cf::face::find "sound/$sound->[1]";
3586 cf::sound::set $sound->[0] => $face;
3587 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3588 }
3589
3590 while (my ($k, $v) = each %{$soundconf->{event}}) {
3591 my $face = cf::face::find "sound/$v";
3592 cf::sound::set $k => $face;
3593 }
3594}
3595
3318sub reload_resources { 3596sub reload_resources {
3319 warn "reloading resource files...\n"; 3597 trace "reloading resource files...\n";
3320 3598
3599 reload_exp_table;
3600 reload_materials;
3321 reload_facedata; 3601 reload_facedata;
3602 reload_sound;
3322 reload_archetypes; 3603 reload_archetypes;
3323 reload_regions; 3604 reload_regions;
3324 reload_treasures; 3605 reload_treasures;
3325 3606
3326 warn "finished reloading resource files\n"; 3607 trace "finished reloading resource files\n";
3327}
3328
3329sub init {
3330 my $guard = freeze_mainloop;
3331
3332 evthread_start IO::AIO::poll_fileno;
3333
3334 reload_resources;
3335} 3608}
3336 3609
3337sub reload_config { 3610sub reload_config {
3338 open my $fh, "<:utf8", "$CONFDIR/config" 3611 trace "reloading config file...\n";
3339 or return;
3340 3612
3341 local $/; 3613 my $config = load_file "$CONFDIR/config";
3342 *CFG = YAML::Load <$fh>; 3614 utf8::decode $config;
3615 *CFG = decode_yaml $config;
3343 3616
3344 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3617 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3345 3618
3346 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3619 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3347 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3620 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3348 3621
3349 if (exists $CFG{mlockall}) { 3622 if (exists $CFG{mlockall}) {
… …
3353 }; 3626 };
3354 warn $@ if $@; 3627 warn $@ if $@;
3355 } 3628 }
3356} 3629}
3357 3630
3631sub pidfile() {
3632 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3633 or die "$PIDFILE: $!";
3634 flock $fh, &Fcntl::LOCK_EX
3635 or die "$PIDFILE: flock: $!";
3636 $fh
3637}
3638
3639# make sure only one server instance is running at any one time
3640sub atomic {
3641 my $fh = pidfile;
3642
3643 my $pid = <$fh>;
3644 kill 9, $pid if $pid > 0;
3645
3646 seek $fh, 0, 0;
3647 print $fh $$;
3648}
3649
3650sub main_loop {
3651 trace "EV::loop starting\n";
3652 if (1) {
3653 EV::loop;
3654 }
3655 trace "EV::loop returned\n";
3656 goto &main_loop unless $REALLY_UNLOOP;
3657}
3658
3358sub main { 3659sub main {
3660 cf::init_globals; # initialise logging
3661
3662 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3663 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3664 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3665 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3666
3667 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3668
3359 # we must not ever block the main coroutine 3669 # we must not ever block the main coroutine
3360 local $Coro::idle = sub { 3670 local $Coro::idle = sub {
3361 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3671 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3362 (async { 3672 (async {
3363 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3673 $Coro::current->{desc} = "IDLE BUG HANDLER";
3364 EV::loop EV::LOOP_ONESHOT; 3674 EV::loop EV::LOOP_ONESHOT;
3365 })->prio (Coro::PRIO_MAX); 3675 })->prio (Coro::PRIO_MAX);
3366 }; 3676 };
3367 3677
3368 { 3678 evthread_start IO::AIO::poll_fileno;
3369 my $guard = freeze_mainloop; 3679
3680 cf::sync_job {
3681 cf::incloader::init ();
3682
3683 cf::init_anim;
3684 cf::init_attackmess;
3685 cf::init_dynamic;
3686
3687 cf::load_settings;
3688
3689 reload_resources;
3370 reload_config; 3690 reload_config;
3371 db_init; 3691 db_init;
3692
3693 cf::init_uuid;
3694 cf::init_signals;
3695 cf::init_skills;
3696
3697 cf::init_beforeplay;
3698
3699 atomic;
3700
3372 load_extensions; 3701 load_extensions;
3373 3702
3374 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3703 utime time, time, $RUNTIMEFILE;
3704
3705 # no (long-running) fork's whatsoever before this point(!)
3706 use POSIX ();
3707 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3708
3709 cf::_post_init 0;
3375 } 3710 };
3376 3711
3377 EV::loop; 3712 cf::object::thawer::errors_are_fatal 0;
3713 info "parse errors in files are no longer fatal from this point on.\n";
3714
3715 my $free_main; $free_main = EV::idle sub {
3716 undef $free_main;
3717 undef &main; # free gobs of memory :)
3718 };
3719
3720 goto &main_loop;
3378} 3721}
3379 3722
3380############################################################################# 3723#############################################################################
3381# initialisation and cleanup 3724# initialisation and cleanup
3382 3725
3383# install some emergency cleanup handlers 3726# install some emergency cleanup handlers
3384BEGIN { 3727BEGIN {
3385 our %SIGWATCHER = (); 3728 our %SIGWATCHER = ();
3386 for my $signal (qw(INT HUP TERM)) { 3729 for my $signal (qw(INT HUP TERM)) {
3387 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3730 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3388 cf::cleanup "SIG$signal"; 3731 cf::cleanup "SIG$signal";
3389 }; 3732 };
3390 } 3733 }
3391} 3734}
3392 3735
3393sub write_runtime_sync { 3736sub write_runtime_sync {
3394 my $runtime = "$LOCALDIR/runtime"; 3737 my $t0 = AE::time;
3395 3738
3396 # first touch the runtime file to show we are still running: 3739 # first touch the runtime file to show we are still running:
3397 # the fsync below can take a very very long time. 3740 # the fsync below can take a very very long time.
3398 3741
3399 IO::AIO::aio_utime $runtime, undef, undef; 3742 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3400 3743
3401 my $guard = cf::lock_acquire "write_runtime"; 3744 my $guard = cf::lock_acquire "write_runtime";
3402 3745
3403 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3746 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3404 or return; 3747 or return;
3405 3748
3406 my $value = $cf::RUNTIME + 90 + 10; 3749 my $value = $cf::RUNTIME + 90 + 10;
3407 # 10 is the runtime save interval, for a monotonic clock 3750 # 10 is the runtime save interval, for a monotonic clock
3408 # 60 allows for the watchdog to kill the server. 3751 # 60 allows for the watchdog to kill the server.
… …
3418 aio_utime $fh, undef, undef; 3761 aio_utime $fh, undef, undef;
3419 3762
3420 close $fh 3763 close $fh
3421 or return; 3764 or return;
3422 3765
3423 aio_rename "$runtime~", $runtime 3766 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3424 and return; 3767 and return;
3425 3768
3426 warn "runtime file written.\n"; 3769 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3427 3770
3428 1 3771 1
3429} 3772}
3430 3773
3431our $uuid_lock; 3774our $uuid_lock;
… …
3440 my $uuid = "$LOCALDIR/uuid"; 3783 my $uuid = "$LOCALDIR/uuid";
3441 3784
3442 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 3785 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3443 or return; 3786 or return;
3444 3787
3445 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; 3788 my $value = uuid_seq uuid_cur;
3789
3790 unless ($value) {
3791 info "cowardly refusing to write zero uuid value!\n";
3792 return;
3793 }
3794
3795 my $value = uuid_str $value + $uuid_skip;
3446 $uuid_skip = 0; 3796 $uuid_skip = 0;
3447 3797
3448 (aio_write $fh, 0, (length $value), $value, 0) <= 0 3798 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3449 and return; 3799 and return;
3450 3800
… …
3456 or return; 3806 or return;
3457 3807
3458 aio_rename "$uuid~", $uuid 3808 aio_rename "$uuid~", $uuid
3459 and return; 3809 and return;
3460 3810
3461 warn "uuid file written ($value).\n"; 3811 trace "uuid file written ($value).\n";
3462 3812
3463 1 3813 1
3464 3814
3465} 3815}
3466 3816
… …
3472} 3822}
3473 3823
3474sub emergency_save() { 3824sub emergency_save() {
3475 my $freeze_guard = cf::freeze_mainloop; 3825 my $freeze_guard = cf::freeze_mainloop;
3476 3826
3477 warn "enter emergency perl save\n"; 3827 info "emergency_perl_save: enter\n";
3828
3829 # this is a trade-off: we want to be very quick here, so
3830 # save all maps without fsync, and later call a global sync
3831 # (which in turn might be very very slow)
3832 local $USE_FSYNC = 0;
3478 3833
3479 cf::sync_job { 3834 cf::sync_job {
3835 cf::write_runtime_sync; # external watchdog should not bark
3836
3480 # use a peculiar iteration method to avoid tripping on perl 3837 # use a peculiar iteration method to avoid tripping on perl
3481 # refcount bugs in for. also avoids problems with players 3838 # refcount bugs in for. also avoids problems with players
3482 # and maps saved/destroyed asynchronously. 3839 # and maps saved/destroyed asynchronously.
3483 warn "begin emergency player save\n"; 3840 info "emergency_perl_save: begin player save\n";
3484 for my $login (keys %cf::PLAYER) { 3841 for my $login (keys %cf::PLAYER) {
3485 my $pl = $cf::PLAYER{$login} or next; 3842 my $pl = $cf::PLAYER{$login} or next;
3486 $pl->valid or next; 3843 $pl->valid or next;
3487 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3844 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3488 $pl->save; 3845 $pl->save;
3489 } 3846 }
3490 warn "end emergency player save\n"; 3847 info "emergency_perl_save: end player save\n";
3491 3848
3492 warn "begin emergency map save\n"; 3849 cf::write_runtime_sync; # external watchdog should not bark
3850
3851 info "emergency_perl_save: begin map save\n";
3493 for my $path (keys %cf::MAP) { 3852 for my $path (keys %cf::MAP) {
3494 my $map = $cf::MAP{$path} or next; 3853 my $map = $cf::MAP{$path} or next;
3495 $map->valid or next; 3854 $map->valid or next;
3496 $map->save; 3855 $map->save;
3497 } 3856 }
3498 warn "end emergency map save\n"; 3857 info "emergency_perl_save: end map save\n";
3499 3858
3500 warn "begin emergency database checkpoint\n"; 3859 cf::write_runtime_sync; # external watchdog should not bark
3860
3861 info "emergency_perl_save: begin database checkpoint\n";
3501 BDB::db_env_txn_checkpoint $DB_ENV; 3862 BDB::db_env_txn_checkpoint $DB_ENV;
3502 warn "end emergency database checkpoint\n"; 3863 info "emergency_perl_save: end database checkpoint\n";
3503 3864
3504 warn "begin write uuid\n"; 3865 info "emergency_perl_save: begin write uuid\n";
3505 write_uuid_sync 1; 3866 write_uuid_sync 1;
3506 warn "end write uuid\n"; 3867 info "emergency_perl_save: end write uuid\n";
3868
3869 cf::write_runtime_sync; # external watchdog should not bark
3870
3871 trace "emergency_perl_save: syncing database to disk";
3872 BDB::db_env_txn_checkpoint $DB_ENV;
3873
3874 info "emergency_perl_save: starting sync\n";
3875 IO::AIO::aio_sync sub {
3876 info "emergency_perl_save: finished sync\n";
3877 };
3878
3879 cf::write_runtime_sync; # external watchdog should not bark
3880
3881 trace "emergency_perl_save: flushing outstanding aio requests";
3882 while (IO::AIO::nreqs || BDB::nreqs) {
3883 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3884 }
3885
3886 cf::write_runtime_sync; # external watchdog should not bark
3507 }; 3887 };
3508 3888
3509 warn "leave emergency perl save\n"; 3889 info "emergency_perl_save: leave\n";
3510} 3890}
3511 3891
3512sub post_cleanup { 3892sub post_cleanup {
3513 my ($make_core) = @_; 3893 my ($make_core) = @_;
3514 3894
3895 IO::AIO::flush;
3896
3515 warn Carp::longmess "post_cleanup backtrace" 3897 error Carp::longmess "post_cleanup backtrace"
3516 if $make_core; 3898 if $make_core;
3899
3900 my $fh = pidfile;
3901 unlink $PIDFILE if <$fh> == $$;
3517} 3902}
3518 3903
3519# a safer delete_package, copied from Symbol 3904# a safer delete_package, copied from Symbol
3520sub clear_package($) { 3905sub clear_package($) {
3521 my $pkg = shift; 3906 my $pkg = shift;
… …
3537 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3922 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3538 for my $name (keys %$leaf_symtab) { 3923 for my $name (keys %$leaf_symtab) {
3539 _gv_clear *{"$pkg$name"}; 3924 _gv_clear *{"$pkg$name"};
3540# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3925# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3541 } 3926 }
3542 warn "cleared package #$pkg\n";#d#
3543} 3927}
3544
3545our $RELOAD; # how many times to reload
3546 3928
3547sub do_reload_perl() { 3929sub do_reload_perl() {
3548 # can/must only be called in main 3930 # can/must only be called in main
3549 if ($Coro::current != $Coro::main) { 3931 unless (in_main) {
3550 warn "can only reload from main coroutine"; 3932 error "can only reload from main coroutine";
3551 return; 3933 return;
3552 } 3934 }
3553 3935
3554 return if $RELOAD++; 3936 return if $RELOAD++;
3555 3937
3938 my $t1 = AE::time;
3939
3556 while ($RELOAD) { 3940 while ($RELOAD) {
3557 warn "reloading..."; 3941 cf::get_slot 0.1, -1, "reload_perl";
3942 info "perl_reload: reloading...";
3558 3943
3559 warn "entering sync_job"; 3944 trace "perl_reload: entering sync_job";
3560 3945
3561 cf::sync_job { 3946 cf::sync_job {
3562 cf::write_runtime_sync; # external watchdog should not bark
3563 cf::emergency_save; 3947 #cf::emergency_save;
3564 cf::write_runtime_sync; # external watchdog should not bark
3565 3948
3566 warn "syncing database to disk";
3567 BDB::db_env_txn_checkpoint $DB_ENV;
3568
3569 # if anything goes wrong in here, we should simply crash as we already saved
3570
3571 warn "flushing outstanding aio requests";
3572 while (IO::AIO::nreqs || BDB::nreqs) {
3573 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3574 }
3575
3576 warn "cancelling all extension coros"; 3949 trace "perl_reload: cancelling all extension coros";
3577 $_->cancel for values %EXT_CORO; 3950 $_->cancel for values %EXT_CORO;
3578 %EXT_CORO = (); 3951 %EXT_CORO = ();
3579 3952
3580 warn "removing commands"; 3953 trace "perl_reload: removing commands";
3581 %COMMAND = (); 3954 %COMMAND = ();
3582 3955
3583 warn "removing ext/exti commands"; 3956 trace "perl_reload: removing ext/exti commands";
3584 %EXTCMD = (); 3957 %EXTCMD = ();
3585 %EXTICMD = (); 3958 %EXTICMD = ();
3586 3959
3587 warn "unloading/nuking all extensions"; 3960 trace "perl_reload: unloading/nuking all extensions";
3588 for my $pkg (@EXTS) { 3961 for my $pkg (@EXTS) {
3589 warn "... unloading $pkg"; 3962 trace "... unloading $pkg";
3590 3963
3591 if (my $cb = $pkg->can ("unload")) { 3964 if (my $cb = $pkg->can ("unload")) {
3592 eval { 3965 eval {
3593 $cb->($pkg); 3966 $cb->($pkg);
3594 1 3967 1
3595 } or warn "$pkg unloaded, but with errors: $@"; 3968 } or error "$pkg unloaded, but with errors: $@";
3596 } 3969 }
3597 3970
3598 warn "... clearing $pkg"; 3971 trace "... clearing $pkg";
3599 clear_package $pkg; 3972 clear_package $pkg;
3600 } 3973 }
3601 3974
3602 warn "unloading all perl modules loaded from $LIBDIR"; 3975 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3603 while (my ($k, $v) = each %INC) { 3976 while (my ($k, $v) = each %INC) {
3604 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3977 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3605 3978
3606 warn "... unloading $k"; 3979 trace "... unloading $k";
3607 delete $INC{$k}; 3980 delete $INC{$k};
3608 3981
3609 $k =~ s/\.pm$//; 3982 $k =~ s/\.pm$//;
3610 $k =~ s/\//::/g; 3983 $k =~ s/\//::/g;
3611 3984
… …
3614 } 3987 }
3615 3988
3616 clear_package $k; 3989 clear_package $k;
3617 } 3990 }
3618 3991
3619 warn "getting rid of safe::, as good as possible"; 3992 trace "perl_reload: getting rid of safe::, as good as possible";
3620 clear_package "safe::$_" 3993 clear_package "safe::$_"
3621 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3994 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3622 3995
3623 warn "unloading cf.pm \"a bit\""; 3996 trace "perl_reload: unloading cf.pm \"a bit\"";
3624 delete $INC{"cf.pm"}; 3997 delete $INC{"cf.pm"};
3625 delete $INC{"cf/pod.pm"}; 3998 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3626 3999
3627 # don't, removes xs symbols, too, 4000 # don't, removes xs symbols, too,
3628 # and global variables created in xs 4001 # and global variables created in xs
3629 #clear_package __PACKAGE__; 4002 #clear_package __PACKAGE__;
3630 4003
3631 warn "unload completed, starting to reload now"; 4004 info "perl_reload: unload completed, starting to reload now";
3632 4005
3633 warn "reloading cf.pm"; 4006 trace "perl_reload: reloading cf.pm";
3634 require cf; 4007 require cf;
3635 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 4008 cf::_connect_to_perl_1;
3636 4009
3637 warn "loading config and database again"; 4010 trace "perl_reload: loading config and database again";
3638 cf::reload_config; 4011 cf::reload_config;
3639 4012
3640 warn "loading extensions"; 4013 trace "perl_reload: loading extensions";
3641 cf::load_extensions; 4014 cf::load_extensions;
3642 4015
4016 if ($REATTACH_ON_RELOAD) {
3643 warn "reattaching attachments to objects/players"; 4017 trace "perl_reload: reattaching attachments to objects/players";
3644 _global_reattach; # objects, sockets 4018 _global_reattach; # objects, sockets
3645 warn "reattaching attachments to maps"; 4019 trace "perl_reload: reattaching attachments to maps";
3646 reattach $_ for values %MAP; 4020 reattach $_ for values %MAP;
3647 warn "reattaching attachments to players"; 4021 trace "perl_reload: reattaching attachments to players";
3648 reattach $_ for values %PLAYER; 4022 reattach $_ for values %PLAYER;
4023 }
3649 4024
3650 warn "leaving sync_job"; 4025 cf::_post_init 1;
4026
4027 trace "perl_reload: leaving sync_job";
3651 4028
3652 1 4029 1
3653 } or do { 4030 } or do {
3654 warn $@; 4031 error $@;
3655 cf::cleanup "error while reloading, exiting."; 4032 cf::cleanup "perl_reload: error, exiting.";
3656 }; 4033 };
3657 4034
3658 warn "reloaded";
3659 --$RELOAD; 4035 --$RELOAD;
3660 } 4036 }
4037
4038 $t1 = AE::time - $t1;
4039 info "perl_reload: completed in ${t1}s\n";
3661}; 4040};
3662 4041
3663our $RELOAD_WATCHER; # used only during reload 4042our $RELOAD_WATCHER; # used only during reload
3664 4043
3665sub reload_perl() { 4044sub reload_perl() {
3666 # doing reload synchronously and two reloads happen back-to-back, 4045 # doing reload synchronously and two reloads happen back-to-back,
3667 # coro crashes during coro_state_free->destroy here. 4046 # coro crashes during coro_state_free->destroy here.
3668 4047
4048 $RELOAD_WATCHER ||= cf::async {
4049 Coro::AIO::aio_wait cache_extensions;
4050
3669 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 4051 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3670 do_reload_perl; 4052 do_reload_perl;
3671 undef $RELOAD_WATCHER; 4053 undef $RELOAD_WATCHER;
4054 };
3672 }; 4055 };
3673} 4056}
3674 4057
3675register_command "reload" => sub { 4058register_command "reload" => sub {
3676 my ($who, $arg) = @_; 4059 my ($who, $arg) = @_;
… …
3682 reload_perl; 4065 reload_perl;
3683 }; 4066 };
3684 } 4067 }
3685}; 4068};
3686 4069
3687unshift @INC, $LIBDIR; 4070#############################################################################
3688 4071
3689my $bug_warning = 0; 4072my $bug_warning = 0;
3690 4073
3691our @WAIT_FOR_TICK; 4074our @WAIT_FOR_TICK;
3692our @WAIT_FOR_TICK_BEGIN; 4075our @WAIT_FOR_TICK_BEGIN;
3693 4076
3694sub wait_for_tick { 4077sub wait_for_tick() {
3695 return if tick_inhibit || $Coro::current == $Coro::main; 4078 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3696 4079
3697 my $signal = new Coro::Signal; 4080 my $signal = new Coro::Signal;
3698 push @WAIT_FOR_TICK, $signal; 4081 push @WAIT_FOR_TICK, $signal;
3699 $signal->wait; 4082 $signal->wait;
3700} 4083}
3701 4084
3702sub wait_for_tick_begin { 4085sub wait_for_tick_begin() {
3703 return if tick_inhibit || $Coro::current == $Coro::main; 4086 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3704 4087
3705 my $signal = new Coro::Signal; 4088 my $signal = new Coro::Signal;
3706 push @WAIT_FOR_TICK_BEGIN, $signal; 4089 push @WAIT_FOR_TICK_BEGIN, $signal;
3707 $signal->wait; 4090 $signal->wait;
3708} 4091}
… …
3714 return; 4097 return;
3715 } 4098 }
3716 4099
3717 cf::server_tick; # one server iteration 4100 cf::server_tick; # one server iteration
3718 4101
4102 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4103
3719 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4104 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3720 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4105 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3721 Coro::async_pool { 4106 Coro::async_pool {
3722 $Coro::current->{desc} = "runtime saver"; 4107 $Coro::current->{desc} = "runtime saver";
3723 write_runtime_sync 4108 write_runtime_sync
3724 or warn "ERROR: unable to write runtime file: $!"; 4109 or error "ERROR: unable to write runtime file: $!";
3725 }; 4110 };
3726 } 4111 }
3727 4112
3728 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4113 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3729 $sig->send; 4114 $sig->send;
… …
3737 4122
3738 if (0) { 4123 if (0) {
3739 if ($NEXT_TICK) { 4124 if ($NEXT_TICK) {
3740 my $jitter = $TICK_START - $NEXT_TICK; 4125 my $jitter = $TICK_START - $NEXT_TICK;
3741 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4126 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3742 warn "jitter $JITTER\n";#d# 4127 debug "jitter $JITTER\n";#d#
3743 } 4128 }
3744 } 4129 }
3745} 4130}
3746 4131
3747{ 4132{
3748 # configure BDB 4133 # configure BDB
3749 4134
3750 BDB::min_parallel 8; 4135 BDB::min_parallel 16;
3751 BDB::max_poll_reqs $TICK * 0.1; 4136 BDB::max_poll_reqs $TICK * 0.1;
3752 $AnyEvent::BDB::WATCHER->priority (1); 4137 $AnyEvent::BDB::WATCHER->priority (1);
3753 4138
3754 unless ($DB_ENV) { 4139 unless ($DB_ENV) {
3755 $DB_ENV = BDB::db_env_create; 4140 $DB_ENV = BDB::db_env_create;
… …
3792 IO::AIO::min_parallel 8; 4177 IO::AIO::min_parallel 8;
3793 IO::AIO::max_poll_time $TICK * 0.1; 4178 IO::AIO::max_poll_time $TICK * 0.1;
3794 undef $AnyEvent::AIO::WATCHER; 4179 undef $AnyEvent::AIO::WATCHER;
3795} 4180}
3796 4181
3797my $_log_backtrace; 4182our $_log_backtrace;
4183our $_log_backtrace_last;
3798 4184
3799sub _log_backtrace { 4185sub _log_backtrace {
3800 my ($msg, @addr) = @_; 4186 my ($msg, @addr) = @_;
3801 4187
3802 $msg =~ s/\n//; 4188 $msg =~ s/\n$//;
3803 4189
4190 if ($_log_backtrace_last eq $msg) {
4191 LOG llevInfo, "[ABT] $msg\n";
4192 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3804 # limit the # of concurrent backtraces 4193 # limit the # of concurrent backtraces
3805 if ($_log_backtrace < 2) { 4194 } elsif ($_log_backtrace < 2) {
4195 $_log_backtrace_last = $msg;
3806 ++$_log_backtrace; 4196 ++$_log_backtrace;
4197 my $perl_bt = Carp::longmess $msg;
3807 async { 4198 async {
3808 $Coro::current->{desc} = "abt $msg"; 4199 $Coro::current->{desc} = "abt $msg";
3809 4200
3810 my @bt = fork_call { 4201 my @bt = fork_call {
3811 @addr = map { sprintf "%x", $_ } @addr; 4202 @addr = map { sprintf "%x", $_ } @addr;
… …
3822 } 4213 }
3823 4214
3824 @funcs 4215 @funcs
3825 }; 4216 };
3826 4217
3827 LOG llevInfo, "[ABT] $msg\n"; 4218 LOG llevInfo, "[ABT] $perl_bt\n";
4219 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3828 LOG llevInfo, "[ABT] $_\n" for @bt; 4220 LOG llevInfo, "[ABT] $_\n" for @bt;
3829 --$_log_backtrace; 4221 --$_log_backtrace;
3830 }; 4222 };
3831 } else { 4223 } else {
3832 LOG llevInfo, "[ABT] $msg\n"; 4224 LOG llevInfo, "[ABT] $msg\n";
3833 LOG llevInfo, "[ABT] [suppressed]\n"; 4225 LOG llevInfo, "[ABT] [overload, suppressed]\n";
3834 } 4226 }
3835} 4227}
3836 4228
3837# load additional modules 4229# load additional modules
3838use cf::pod; 4230require "cf/$_.pm" for @EXTRA_MODULES;
4231cf::_connect_to_perl_2;
3839 4232
3840END { cf::emergency_save } 4233END { cf::emergency_save }
3841 4234
38421 42351
3843 4236

Diff Legend

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