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.570 by root, Wed May 4 07:41:14 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,2011 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}
… …
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} 2038}
1848 2039
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}
1857
1858sub decay_objects { 2040sub decay_objects {
1859 my ($self) = @_; 2041 my ($self) = @_;
1860 2042
1861 return if $self->{deny_reset}; 2043 return if $self->{deny_reset};
1862 2044
… …
1887 $self->{load_path} = $path; 2069 $self->{load_path} = $path;
1888 2070
1889 1 2071 1
1890} 2072}
1891 2073
2074# used to laod the header of an original map
1892sub load_header_orig { 2075sub load_header_orig {
1893 my ($self) = @_; 2076 my ($self) = @_;
1894 2077
1895 $self->load_header_from ($self->load_path) 2078 $self->load_header_from ($self->load_path)
1896} 2079}
1897 2080
2081# used to laod the header of an instantiated map
1898sub load_header_temp { 2082sub load_header_temp {
1899 my ($self) = @_; 2083 my ($self) = @_;
1900 2084
1901 $self->load_header_from ($self->save_path) 2085 $self->load_header_from ($self->save_path)
1902} 2086}
1903 2087
2088# called after loading the header from an instantiated map
1904sub prepare_temp { 2089sub prepare_temp {
1905 my ($self) = @_; 2090 my ($self) = @_;
1906 2091
1907 $self->last_access ((delete $self->{last_access}) 2092 $self->last_access ((delete $self->{last_access})
1908 || $cf::RUNTIME); #d# 2093 || $cf::RUNTIME); #d#
1909 # safety 2094 # safety
1910 $self->{instantiate_time} = $cf::RUNTIME 2095 $self->{instantiate_time} = $cf::RUNTIME
1911 if $self->{instantiate_time} > $cf::RUNTIME; 2096 if $self->{instantiate_time} > $cf::RUNTIME;
1912} 2097}
1913 2098
2099# called after loading the header from an original map
1914sub prepare_orig { 2100sub prepare_orig {
1915 my ($self) = @_; 2101 my ($self) = @_;
1916 2102
1917 $self->{load_original} = 1; 2103 $self->{load_original} = 1;
1918 $self->{instantiate_time} = $cf::RUNTIME; 2104 $self->{instantiate_time} = $cf::RUNTIME;
… …
1942 2128
1943sub find; 2129sub find;
1944sub find { 2130sub find {
1945 my ($path, $origin) = @_; 2131 my ($path, $origin) = @_;
1946 2132
2133 cf::cede_to_tick;
2134
1947 $path = normalise $path, $origin && $origin->path; 2135 $path = normalise $path, $origin;
1948 2136
1949 cf::lock_wait "map_data:$path";#d#remove 2137 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1950 cf::lock_wait "map_find:$path"; 2138 my $guard2 = cf::lock_acquire "map_find:$path";
1951 2139
1952 $cf::MAP{$path} || do { 2140 $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 2141 my $map = new_from_path cf::map $path
1957 or return; 2142 or return;
1958 2143
1959 $map->{last_save} = $cf::RUNTIME; 2144 $map->{last_save} = $cf::RUNTIME;
1960 2145
… …
1972 2157
1973 $cf::MAP{$path} = $map 2158 $cf::MAP{$path} = $map
1974 } 2159 }
1975} 2160}
1976 2161
1977sub pre_load { } 2162sub pre_load { }
1978sub post_load { } 2163#sub post_load { } # XS
1979 2164
1980sub load { 2165sub load {
1981 my ($self) = @_; 2166 my ($self) = @_;
1982 2167
1983 local $self->{deny_reset} = 1; # loading can take a long time 2168 local $self->{deny_reset} = 1; # loading can take a long time
… …
1986 2171
1987 { 2172 {
1988 my $guard = cf::lock_acquire "map_data:$path"; 2173 my $guard = cf::lock_acquire "map_data:$path";
1989 2174
1990 return unless $self->valid; 2175 return unless $self->valid;
1991 return unless $self->in_memory == cf::MAP_SWAPPED; 2176 return unless $self->state == cf::MAP_SWAPPED;
1992
1993 $self->in_memory (cf::MAP_LOADING);
1994 2177
1995 $self->alloc; 2178 $self->alloc;
1996 2179
1997 $self->pre_load; 2180 $self->pre_load;
1998 cf::cede_to_tick; 2181 cf::cede_to_tick;
1999 2182
2183 if (exists $self->{load_path}) {
2000 my $f = new_from_file cf::object::thawer $self->{load_path}; 2184 my $f = new_from_file cf::object::thawer $self->{load_path};
2001 $f->skip_block; 2185 $f->skip_block;
2002 $self->_load_objects ($f) 2186 $self->_load_objects ($f)
2003 or return; 2187 or return;
2004 2188
2005 $self->post_load_original 2189 $self->post_load_original
2006 if delete $self->{load_original}; 2190 if delete $self->{load_original};
2007 2191
2008 if (my $uniq = $self->uniq_path) { 2192 if (my $uniq = $self->uniq_path) {
2009 utf8::encode $uniq; 2193 utf8::encode $uniq;
2010 unless (aio_stat $uniq) { 2194 unless (aio_stat $uniq) {
2011 if (my $f = new_from_file cf::object::thawer $uniq) { 2195 if (my $f = new_from_file cf::object::thawer $uniq) {
2012 $self->clear_unique_items; 2196 $self->clear_unique_items;
2013 $self->_load_objects ($f); 2197 $self->_load_objects ($f);
2014 $f->resolve_delayed_derefs; 2198 $f->resolve_delayed_derefs;
2199 }
2015 } 2200 }
2016 } 2201 }
2017 }
2018 2202
2019 $f->resolve_delayed_derefs; 2203 $f->resolve_delayed_derefs;
2204 } else {
2205 $self->post_load_original
2206 if delete $self->{load_original};
2207 }
2208
2209 $self->state (cf::MAP_INACTIVE);
2020 2210
2021 cf::cede_to_tick; 2211 cf::cede_to_tick;
2022 # now do the right thing for maps 2212 # now do the right thing for maps
2023 $self->link_multipart_objects; 2213 $self->link_multipart_objects;
2024 $self->difficulty ($self->estimate_difficulty) 2214 $self->difficulty ($self->estimate_difficulty)
… …
2028 unless ($self->{deny_activate}) { 2218 unless ($self->{deny_activate}) {
2029 $self->decay_objects; 2219 $self->decay_objects;
2030 $self->fix_auto_apply; 2220 $self->fix_auto_apply;
2031 $self->update_buttons; 2221 $self->update_buttons;
2032 cf::cede_to_tick; 2222 cf::cede_to_tick;
2033 $self->set_darkness_map; 2223 #$self->activate; # no longer activate maps automatically
2034 cf::cede_to_tick;
2035 $self->activate;
2036 } 2224 }
2037 2225
2038 $self->{last_save} = $cf::RUNTIME; 2226 $self->{last_save} = $cf::RUNTIME;
2039 $self->last_access ($cf::RUNTIME); 2227 $self->last_access ($cf::RUNTIME);
2040
2041 $self->in_memory (cf::MAP_ACTIVE);
2042 } 2228 }
2043 2229
2044 $self->post_load; 2230 $self->post_load;
2045}
2046 2231
2232 1
2233}
2234
2235# customize the map for a given player, i.e.
2236# return the _real_ map. used by e.g. per-player
2237# maps to change the path to ~playername/mappath
2047sub customise_for { 2238sub customise_for {
2048 my ($self, $ob) = @_; 2239 my ($self, $ob) = @_;
2049 2240
2050 return find "~" . $ob->name . "/" . $self->{path} 2241 return find "~" . $ob->name . "/" . $self->{path}
2051 if $self->per_player; 2242 if $self->per_player;
… …
2067 or next; 2258 or next;
2068 $neigh = find $neigh, $map 2259 $neigh = find $neigh, $map
2069 or next; 2260 or next;
2070 $neigh->load; 2261 $neigh->load;
2071 2262
2263 # now find the diagonal neighbours
2072 push @neigh, 2264 push @neigh,
2073 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2265 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2074 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2266 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2075 } 2267 }
2076 2268
… …
2083} 2275}
2084 2276
2085sub find_sync { 2277sub find_sync {
2086 my ($path, $origin) = @_; 2278 my ($path, $origin) = @_;
2087 2279
2088 cf::sync_job { find $path, $origin } 2280 # it's a bug to call this from the main context
2281 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2282 if $Coro::current == $Coro::main;
2283
2284 find $path, $origin
2089} 2285}
2090 2286
2091sub do_load_sync { 2287sub do_load_sync {
2092 my ($map) = @_; 2288 my ($map) = @_;
2093 2289
2290 # it's a bug to call this from the main context
2094 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2291 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2095 if $Coro::current == $Coro::main; 2292 if $Coro::current == $Coro::main;
2096 2293
2097 cf::sync_job { $map->load }; 2294 $map->load;
2098} 2295}
2099 2296
2100our %MAP_PREFETCH; 2297our %MAP_PREFETCH;
2101our $MAP_PREFETCHER = undef; 2298our $MAP_PREFETCHER = undef;
2102 2299
2103sub find_async { 2300sub find_async {
2104 my ($path, $origin, $load) = @_; 2301 my ($path, $origin, $load) = @_;
2105 2302
2106 $path = normalise $path, $origin && $origin->{path}; 2303 $path = normalise $path, $origin;
2107 2304
2108 if (my $map = $cf::MAP{$path}) { 2305 if (my $map = $cf::MAP{$path}) {
2109 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE; 2306 return $map if !$load || $map->linkable;
2110 } 2307 }
2111 2308
2112 $MAP_PREFETCH{$path} |= $load; 2309 $MAP_PREFETCH{$path} |= $load;
2113 2310
2114 $MAP_PREFETCHER ||= cf::async { 2311 $MAP_PREFETCHER ||= cf::async {
… …
2128 $MAP_PREFETCHER->prio (6); 2325 $MAP_PREFETCHER->prio (6);
2129 2326
2130 () 2327 ()
2131} 2328}
2132 2329
2330# common code, used by both ->save and ->swapout
2133sub save { 2331sub _save {
2134 my ($self) = @_; 2332 my ($self) = @_;
2135
2136 my $lock = cf::lock_acquire "map_data:$self->{path}";
2137 2333
2138 $self->{last_save} = $cf::RUNTIME; 2334 $self->{last_save} = $cf::RUNTIME;
2139 2335
2140 return unless $self->dirty; 2336 return unless $self->dirty;
2141 2337
… …
2161 } else { 2357 } else {
2162 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2358 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2163 } 2359 }
2164} 2360}
2165 2361
2362sub save {
2363 my ($self) = @_;
2364
2365 my $lock = cf::lock_acquire "map_data:$self->{path}";
2366
2367 $self->_save;
2368}
2369
2166sub swap_out { 2370sub swap_out {
2167 my ($self) = @_; 2371 my ($self) = @_;
2168 2372
2169 # save first because save cedes
2170 $self->save;
2171
2172 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2373 my $lock = cf::lock_acquire "map_data:$self->{path}";
2173 2374
2375 return if !$self->linkable;
2376 return if $self->{deny_save};
2174 return if $self->players; 2377 return if $self->players;
2175 return if $self->in_memory != cf::MAP_ACTIVE; 2378
2379 # first deactivate the map and "unlink" it from the core
2380 $self->deactivate;
2381 $_->clear_links_to ($self) for values %cf::MAP;
2382 $self->state (cf::MAP_SWAPPED);
2383
2384 # then atomically save
2385 $self->_save;
2386
2387 # then free the map
2388 $self->clear;
2389}
2390
2391sub reset_at {
2392 my ($self) = @_;
2393
2394 # TODO: safety, remove and allow resettable per-player maps
2176 return if $self->{deny_save}; 2395 return 1e99 if $self->{deny_reset};
2177 2396
2397 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2398 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2399
2400 $time + $to
2401}
2402
2403sub should_reset {
2404 my ($self) = @_;
2405
2406 $self->reset_at <= $cf::RUNTIME
2407}
2408
2409sub reset {
2410 my ($self) = @_;
2411
2412 my $lock = cf::lock_acquire "map_data:$self->{path}";
2413
2414 return if $self->players;
2415
2416 cf::trace "resetting map ", $self->path, "\n";
2417
2178 $self->in_memory (cf::MAP_SWAPPED); 2418 $self->state (cf::MAP_SWAPPED);
2419
2420 # need to save uniques path
2421 unless ($self->{deny_save}) {
2422 my $uniq = $self->uniq_path; utf8::encode $uniq;
2423
2424 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2425 if $uniq;
2426 }
2427
2428 delete $cf::MAP{$self->path};
2179 2429
2180 $self->deactivate; 2430 $self->deactivate;
2181 $_->clear_links_to ($self) for values %cf::MAP; 2431 $_->clear_links_to ($self) for values %cf::MAP;
2182 $self->clear; 2432 $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 2433
2228 $self->unlink_save; 2434 $self->unlink_save;
2229 $self->destroy; 2435 $self->destroy;
2230} 2436}
2231 2437
… …
2239 2445
2240 delete $cf::MAP{$self->path}; 2446 delete $cf::MAP{$self->path};
2241 2447
2242 $self->unlink_save; 2448 $self->unlink_save;
2243 2449
2244 bless $self, "cf::map"; 2450 bless $self, "cf::map::wrap";
2245 delete $self->{deny_reset}; 2451 delete $self->{deny_reset};
2246 $self->{deny_save} = 1; 2452 $self->{deny_save} = 1;
2247 $self->reset_timeout (1); 2453 $self->reset_timeout (1);
2248 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2454 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2249 2455
… …
2306 : normalise $_ 2512 : normalise $_
2307 } @{ aio_readdir $UNIQUEDIR or [] } 2513 } @{ aio_readdir $UNIQUEDIR or [] }
2308 ] 2514 ]
2309} 2515}
2310 2516
2517=item cf::map::static_maps
2518
2519Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2520file in the shared directory excluding F</styles> and F</editor>). May
2521block.
2522
2523=cut
2524
2525sub static_maps() {
2526 my @dirs = "";
2527 my @maps;
2528
2529 while (@dirs) {
2530 my $dir = shift @dirs;
2531
2532 next if $dir eq "/styles" || $dir eq "/editor";
2533
2534 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2535 or return;
2536
2537 for (@$files) {
2538 s/\.map$// or next;
2539 utf8::decode $_;
2540 push @maps, "$dir/$_";
2541 }
2542
2543 push @dirs, map "$dir/$_", @$dirs;
2544 }
2545
2546 \@maps
2547}
2548
2311=back 2549=back
2312 2550
2313=head3 cf::object 2551=head3 cf::object
2314 2552
2315=cut 2553=cut
… …
2380 2618
2381our $SAY_CHANNEL = { 2619our $SAY_CHANNEL = {
2382 id => "say", 2620 id => "say",
2383 title => "Map", 2621 title => "Map",
2384 reply => "say ", 2622 reply => "say ",
2385 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2623 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2386}; 2624};
2387 2625
2388our $CHAT_CHANNEL = { 2626our $CHAT_CHANNEL = {
2389 id => "chat", 2627 id => "chat",
2390 title => "Chat", 2628 title => "Chat",
… …
2445 2683
2446=item $player_object->enter_link 2684=item $player_object->enter_link
2447 2685
2448Freezes the player and moves him/her to a special map (C<{link}>). 2686Freezes the player and moves him/her to a special map (C<{link}>).
2449 2687
2450The player should be reasonably safe there for short amounts of time. You 2688The player should be reasonably safe there for short amounts of time (e.g.
2451I<MUST> call C<leave_link> as soon as possible, though. 2689for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2690though, as the player cannot control the character while it is on the link
2691map.
2452 2692
2453Will never block. 2693Will never block.
2454 2694
2455=item $player_object->leave_link ($map, $x, $y) 2695=item $player_object->leave_link ($map, $x, $y)
2456 2696
… …
2476sub cf::object::player::enter_link { 2716sub cf::object::player::enter_link {
2477 my ($self) = @_; 2717 my ($self) = @_;
2478 2718
2479 $self->deactivate_recursive; 2719 $self->deactivate_recursive;
2480 2720
2721 ++$self->{_link_recursion};
2722
2481 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2723 return if UNIVERSAL::isa $self->map, "ext::map_link";
2482 2724
2483 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2725 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2484 if $self->map && $self->map->{path} ne "{link}"; 2726 if $self->map && $self->map->{path} ne "{link}";
2485 2727
2486 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2728 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2487} 2729}
2488 2730
2489sub cf::object::player::leave_link { 2731sub cf::object::player::leave_link {
2490 my ($self, $map, $x, $y) = @_; 2732 my ($self, $map, $x, $y) = @_;
2491 2733
… …
2508 ($x, $y) = (-1, -1) 2750 ($x, $y) = (-1, -1)
2509 unless (defined $x) && (defined $y); 2751 unless (defined $x) && (defined $y);
2510 2752
2511 # use -1 or undef as default coordinates, not 0, 0 2753 # use -1 or undef as default coordinates, not 0, 0
2512 ($x, $y) = ($map->enter_x, $map->enter_y) 2754 ($x, $y) = ($map->enter_x, $map->enter_y)
2513 if $x <=0 && $y <= 0; 2755 if $x <= 0 && $y <= 0;
2514 2756
2515 $map->load; 2757 $map->load;
2516 $map->load_neighbours; 2758 $map->load_neighbours;
2517 2759
2518 return unless $self->contr->active; 2760 return unless $self->contr->active;
2519 $self->activate_recursive;
2520 2761
2521 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2762 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2522 $self->enter_map ($map, $x, $y); 2763 if ($self->enter_map ($map, $x, $y)) {
2523} 2764 # entering was successful
2765 delete $self->{_link_recursion};
2766 # only activate afterwards, to support waiting in hooks
2767 $self->activate_recursive;
2768 }
2524 2769
2770}
2771
2525=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2772=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2526 2773
2527Moves the player to the given map-path and coordinates by first freezing 2774Moves the player to the given map-path and coordinates by first freezing
2528her, loading and preparing them map, calling the provided $check callback 2775her, loading and preparing them map, calling the provided $check callback
2529that has to return the map if sucecssful, and then unfreezes the player on 2776that 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 2777the new (success) or old (failed) map position. In either case, $done will
… …
2537 2784
2538our $GOTOGEN; 2785our $GOTOGEN;
2539 2786
2540sub cf::object::player::goto { 2787sub cf::object::player::goto {
2541 my ($self, $path, $x, $y, $check, $done) = @_; 2788 my ($self, $path, $x, $y, $check, $done) = @_;
2789
2790 if ($self->{_link_recursion} >= $MAX_LINKS) {
2791 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2792 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2793 ($path, $x, $y) = @$EMERGENCY_POSITION;
2794 }
2542 2795
2543 # do generation counting so two concurrent goto's will be executed in-order 2796 # do generation counting so two concurrent goto's will be executed in-order
2544 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2797 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2545 2798
2546 $self->enter_link; 2799 $self->enter_link;
… …
2566 ($path, $x, $y) = (undef, undef, undef); 2819 ($path, $x, $y) = (undef, undef, undef);
2567 } 2820 }
2568 } 2821 }
2569 2822
2570 my $map = eval { 2823 my $map = eval {
2571 my $map = defined $path ? cf::map::find $path : undef; 2824 my $map = defined $path ? cf::map::find $path, $self->map : undef;
2572 2825
2573 if ($map) { 2826 if ($map) {
2574 $map = $map->customise_for ($self); 2827 $map = $map->customise_for ($self);
2575 $map = $check->($map) if $check && $map; 2828 $map = $check->($map, $x, $y, $self) if $check && $map;
2576 } else { 2829 } else {
2577 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2830 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2578 } 2831 }
2579 2832
2580 $map 2833 $map
… …
2588 if ($gen == $self->{_goto_generation}) { 2841 if ($gen == $self->{_goto_generation}) {
2589 delete $self->{_goto_generation}; 2842 delete $self->{_goto_generation};
2590 $self->leave_link ($map, $x, $y); 2843 $self->leave_link ($map, $x, $y);
2591 } 2844 }
2592 2845
2593 $done->() if $done; 2846 $done->($self) if $done;
2594 })->prio (1); 2847 })->prio (1);
2595} 2848}
2596 2849
2597=item $player_object->enter_exit ($exit_object) 2850=item $player_object->enter_exit ($exit_object)
2598 2851
… …
2666 $Coro::current->{desc} = "enter_exit"; 2919 $Coro::current->{desc} = "enter_exit";
2667 2920
2668 unless (eval { 2921 unless (eval {
2669 $self->deactivate_recursive; # just to be sure 2922 $self->deactivate_recursive; # just to be sure
2670 2923
2671 # random map handling
2672 {
2673 my $guard = cf::lock_acquire "exit_prepare:$exit";
2674
2675 prepare_random_map $exit
2676 if $exit->slaying eq "/!";
2677 }
2678
2679 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2924 my $map = cf::map::normalise $exit->slaying, $exit->map;
2680 my $x = $exit->stats->hp; 2925 my $x = $exit->stats->hp;
2681 my $y = $exit->stats->sp; 2926 my $y = $exit->stats->sp;
2927
2928 # special map handling
2929 my $slaying = $exit->slaying;
2930
2931 # special map handling
2932 if ($slaying eq "/!") {
2933 my $guard = cf::lock_acquire "exit_prepare:$exit";
2934
2935 prepare_random_map $exit
2936 if $exit->slaying eq "/!"; # need to re-check after getting the lock
2937
2938 $map = $exit->slaying;
2939
2940 } elsif ($slaying eq '!up') {
2941 $map = $exit->map->tile_path (cf::TILE_UP);
2942 $x = $exit->x;
2943 $y = $exit->y;
2944
2945 } elsif ($slaying eq '!down') {
2946 $map = $exit->map->tile_path (cf::TILE_DOWN);
2947 $x = $exit->x;
2948 $y = $exit->y;
2949 }
2682 2950
2683 $self->goto ($map, $x, $y); 2951 $self->goto ($map, $x, $y);
2684 2952
2685 # if exit is damned, update players death & WoR home-position 2953 # if exit is damned, update players death & WoR home-position
2686 $self->contr->savebed ($map, $x, $y) 2954 $self->contr->savebed ($map, $x, $y)
2687 if $exit->flag (cf::FLAG_DAMNED); 2955 if $exit->flag (cf::FLAG_DAMNED);
2688 2956
2689 1 2957 1
2690 }) { 2958 }) {
2691 $self->message ("Something went wrong deep within the crossfire server. " 2959 $self->message ("Something went wrong deep within the deliantra server. "
2692 . "I'll try to bring you back to the map you were before. " 2960 . "I'll try to bring you back to the map you were before. "
2693 . "Please report this to the dungeon master!", 2961 . "Please report this to the dungeon master!",
2694 cf::NDI_UNIQUE | cf::NDI_RED); 2962 cf::NDI_UNIQUE | cf::NDI_RED);
2695 2963
2696 warn "ERROR in enter_exit: $@"; 2964 error "ERROR in enter_exit: $@";
2697 $self->leave_link; 2965 $self->leave_link;
2698 } 2966 }
2699 })->prio (1); 2967 })->prio (1);
2700} 2968}
2701 2969
… …
2713sub cf::client::send_drawinfo { 2981sub cf::client::send_drawinfo {
2714 my ($self, $text, $flags) = @_; 2982 my ($self, $text, $flags) = @_;
2715 2983
2716 utf8::encode $text; 2984 utf8::encode $text;
2717 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2985 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2986}
2987
2988=item $client->send_big_packet ($pkt)
2989
2990Like C<send_packet>, but tries to compress large packets, and fragments
2991them as required.
2992
2993=cut
2994
2995our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2996
2997sub cf::client::send_big_packet {
2998 my ($self, $pkt) = @_;
2999
3000 # try lzf for large packets
3001 $pkt = "lzf " . Compress::LZF::compress $pkt
3002 if 1024 <= length $pkt and $self->{can_lzf};
3003
3004 # split very large packets
3005 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
3006 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
3007 $pkt = "frag";
3008 }
3009
3010 $self->send_packet ($pkt);
2718} 3011}
2719 3012
2720=item $client->send_msg ($channel, $msg, $color, [extra...]) 3013=item $client->send_msg ($channel, $msg, $color, [extra...])
2721 3014
2722Send a drawinfo or msg packet to the client, formatting the msg for the 3015Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2726 3019
2727=cut 3020=cut
2728 3021
2729# non-persistent channels (usually the info channel) 3022# non-persistent channels (usually the info channel)
2730our %CHANNEL = ( 3023our %CHANNEL = (
3024 "c/motd" => {
3025 id => "infobox",
3026 title => "MOTD",
3027 reply => undef,
3028 tooltip => "The message of the day",
3029 },
2731 "c/identify" => { 3030 "c/identify" => {
2732 id => "infobox", 3031 id => "infobox",
2733 title => "Identify", 3032 title => "Identify",
2734 reply => undef, 3033 reply => undef,
2735 tooltip => "Items recently identified", 3034 tooltip => "Items recently identified",
… …
2737 "c/examine" => { 3036 "c/examine" => {
2738 id => "infobox", 3037 id => "infobox",
2739 title => "Examine", 3038 title => "Examine",
2740 reply => undef, 3039 reply => undef,
2741 tooltip => "Signs and other items you examined", 3040 tooltip => "Signs and other items you examined",
3041 },
3042 "c/shopinfo" => {
3043 id => "infobox",
3044 title => "Shop Info",
3045 reply => undef,
3046 tooltip => "What your bargaining skill tells you about the shop",
2742 }, 3047 },
2743 "c/book" => { 3048 "c/book" => {
2744 id => "infobox", 3049 id => "infobox",
2745 title => "Book", 3050 title => "Book",
2746 reply => undef, 3051 reply => undef,
… …
2762 id => "infobox", 3067 id => "infobox",
2763 title => "Body Parts", 3068 title => "Body Parts",
2764 reply => undef, 3069 reply => undef,
2765 tooltip => "Shows which body parts you posess and are available", 3070 tooltip => "Shows which body parts you posess and are available",
2766 }, 3071 },
3072 "c/statistics" => {
3073 id => "infobox",
3074 title => "Statistics",
3075 reply => undef,
3076 tooltip => "Shows your primary statistics",
3077 },
3078 "c/skills" => {
3079 id => "infobox",
3080 title => "Skills",
3081 reply => undef,
3082 tooltip => "Shows your experience per skill and item power",
3083 },
3084 "c/shopitems" => {
3085 id => "infobox",
3086 title => "Shop Items",
3087 reply => undef,
3088 tooltip => "Shows the items currently for sale in this shop",
3089 },
3090 "c/resistances" => {
3091 id => "infobox",
3092 title => "Resistances",
3093 reply => undef,
3094 tooltip => "Shows your resistances",
3095 },
3096 "c/pets" => {
3097 id => "infobox",
3098 title => "Pets",
3099 reply => undef,
3100 tooltip => "Shows information abotu your pets/a specific pet",
3101 },
3102 "c/perceiveself" => {
3103 id => "infobox",
3104 title => "Perceive Self",
3105 reply => undef,
3106 tooltip => "You gained detailed knowledge about yourself",
3107 },
2767 "c/uptime" => { 3108 "c/uptime" => {
2768 id => "infobox", 3109 id => "infobox",
2769 title => "Uptime", 3110 title => "Uptime",
2770 reply => undef, 3111 reply => undef,
2771 tooltip => "How long the server has been running since last restart", 3112 tooltip => "How long the server has been running since last restart",
… …
2780 id => "party", 3121 id => "party",
2781 title => "Party", 3122 title => "Party",
2782 reply => "gsay ", 3123 reply => "gsay ",
2783 tooltip => "Messages and chat related to your party", 3124 tooltip => "Messages and chat related to your party",
2784 }, 3125 },
3126 "c/death" => {
3127 id => "death",
3128 title => "Death",
3129 reply => undef,
3130 tooltip => "Reason for and more info about your most recent death",
3131 },
3132 "c/say" => $SAY_CHANNEL,
3133 "c/chat" => $CHAT_CHANNEL,
2785); 3134);
2786 3135
2787sub cf::client::send_msg { 3136sub cf::client::send_msg {
2788 my ($self, $channel, $msg, $color, @extra) = @_; 3137 my ($self, $channel, $msg, $color, @extra) = @_;
2789 3138
2790 $msg = $self->pl->expand_cfpod ($msg); 3139 $msg = $self->pl->expand_cfpod ($msg)
3140 unless $color & cf::NDI_VERBATIM;
2791 3141
2792 $color &= cf::NDI_CLIENT_MASK; # just in case... 3142 $color &= cf::NDI_CLIENT_MASK; # just in case...
2793 3143
2794 # check predefined channels, for the benefit of C 3144 # check predefined channels, for the benefit of C
2795 if ($CHANNEL{$channel}) { 3145 if ($CHANNEL{$channel}) {
2796 $channel = $CHANNEL{$channel}; 3146 $channel = $CHANNEL{$channel};
2797 3147
2798 $self->ext_msg (channel_info => $channel) 3148 $self->ext_msg (channel_info => $channel);
2799 if $self->can_msg;
2800
2801 $channel = $channel->{id}; 3149 $channel = $channel->{id};
2802 3150
2803 } elsif (ref $channel) { 3151 } elsif (ref $channel) {
2804 # send meta info to client, if not yet sent 3152 # send meta info to client, if not yet sent
2805 unless (exists $self->{channel}{$channel->{id}}) { 3153 unless (exists $self->{channel}{$channel->{id}}) {
2806 $self->{channel}{$channel->{id}} = $channel; 3154 $self->{channel}{$channel->{id}} = $channel;
2807 $self->ext_msg (channel_info => $channel) 3155 $self->ext_msg (channel_info => $channel);
2808 if $self->can_msg;
2809 } 3156 }
2810 3157
2811 $channel = $channel->{id}; 3158 $channel = $channel->{id};
2812 } 3159 }
2813 3160
2814 return unless @extra || length $msg; 3161 return unless @extra || length $msg;
2815 3162
2816 if ($self->can_msg) {
2817 # default colour, mask it out 3163 # default colour, mask it out
2818 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3164 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2819 if $color & cf::NDI_DEF; 3165 if $color & cf::NDI_DEF;
2820 3166
2821 my $pkt = "msg " 3167 my $pkt = "msg "
2822 . $self->{json_coder}->encode ( 3168 . $self->{json_coder}->encode (
2823 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra] 3169 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2824 ); 3170 );
2825 3171
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); 3172 $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} 3173}
2863 3174
2864=item $client->ext_msg ($type, @msg) 3175=item $client->ext_msg ($type, @msg)
2865 3176
2866Sends an ext event to the client. 3177Sends an ext event to the client.
… …
2869 3180
2870sub cf::client::ext_msg($$@) { 3181sub cf::client::ext_msg($$@) {
2871 my ($self, $type, @msg) = @_; 3182 my ($self, $type, @msg) = @_;
2872 3183
2873 if ($self->extcmd == 2) { 3184 if ($self->extcmd == 2) {
2874 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3185 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2875 } elsif ($self->extcmd == 1) { # TODO: remove 3186 } elsif ($self->extcmd == 1) { # TODO: remove
2876 push @msg, msgtype => "event_$type"; 3187 push @msg, msgtype => "event_$type";
2877 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3188 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2878 } 3189 }
2879} 3190}
2880 3191
2881=item $client->ext_reply ($msgid, @msg) 3192=item $client->ext_reply ($msgid, @msg)
2882 3193
… …
2886 3197
2887sub cf::client::ext_reply($$@) { 3198sub cf::client::ext_reply($$@) {
2888 my ($self, $id, @msg) = @_; 3199 my ($self, $id, @msg) = @_;
2889 3200
2890 if ($self->extcmd == 2) { 3201 if ($self->extcmd == 2) {
2891 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3202 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2892 } elsif ($self->extcmd == 1) { 3203 } elsif ($self->extcmd == 1) {
2893 #TODO: version 1, remove 3204 #TODO: version 1, remove
2894 unshift @msg, msgtype => "reply", msgid => $id; 3205 unshift @msg, msgtype => "reply", msgid => $id;
2895 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3206 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2896 } 3207 }
2897} 3208}
2898 3209
2899=item $success = $client->query ($flags, "text", \&cb) 3210=item $success = $client->query ($flags, "text", \&cb)
2900 3211
… …
2971 3282
2972 $ns->ext_reply ($reply, @reply) 3283 $ns->ext_reply ($reply, @reply)
2973 if $reply; 3284 if $reply;
2974 3285
2975 } else { 3286 } else {
2976 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3287 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2977 } 3288 }
2978 3289
2979 cf::override; 3290 cf::override;
2980 }, 3291 },
2981); 3292);
… …
3001 3312
3002 $coro 3313 $coro
3003} 3314}
3004 3315
3005cf::client->attach ( 3316cf::client->attach (
3006 on_destroy => sub { 3317 on_client_destroy => sub {
3007 my ($ns) = @_; 3318 my ($ns) = @_;
3008 3319
3009 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3320 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3010 }, 3321 },
3011); 3322);
… …
3027our $safe_hole = new Safe::Hole; 3338our $safe_hole = new Safe::Hole;
3028 3339
3029$SIG{FPE} = 'IGNORE'; 3340$SIG{FPE} = 'IGNORE';
3030 3341
3031$safe->permit_only (Opcode::opset qw( 3342$safe->permit_only (Opcode::opset qw(
3032 :base_core :base_mem :base_orig :base_math 3343 :base_core :base_mem :base_orig :base_math :base_loop
3033 grepstart grepwhile mapstart mapwhile 3344 grepstart grepwhile mapstart mapwhile
3034 sort time 3345 sort time
3035)); 3346));
3036 3347
3037# here we export the classes and methods available to script code 3348# here we export the classes and methods available to script code
… …
3041The following functions and methods are available within a safe environment: 3352The following functions and methods are available within a safe environment:
3042 3353
3043 cf::object 3354 cf::object
3044 contr pay_amount pay_player map x y force_find force_add destroy 3355 contr pay_amount pay_player map x y force_find force_add destroy
3045 insert remove name archname title slaying race decrease split 3356 insert remove name archname title slaying race decrease split
3357 value
3046 3358
3047 cf::object::player 3359 cf::object::player
3048 player 3360 player
3049 3361
3050 cf::player 3362 cf::player
… …
3056=cut 3368=cut
3057 3369
3058for ( 3370for (
3059 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3371 ["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 3372 insert remove inv nrof name archname title slaying race
3061 decrease split destroy change_exp)], 3373 decrease split destroy change_exp value msg lore send_msg)],
3062 ["cf::object::player" => qw(player)], 3374 ["cf::object::player" => qw(player)],
3063 ["cf::player" => qw(peaceful)], 3375 ["cf::player" => qw(peaceful send_msg)],
3064 ["cf::map" => qw(trigger)], 3376 ["cf::map" => qw(trigger)],
3065) { 3377) {
3066 no strict 'refs';
3067 my ($pkg, @funs) = @$_; 3378 my ($pkg, @funs) = @$_;
3068 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3379 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3069 for @funs; 3380 for @funs;
3070} 3381}
3071 3382
… …
3086 3397
3087 my $qcode = $code; 3398 my $qcode = $code;
3088 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3399 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3089 $qcode =~ s/\n/\\n/g; 3400 $qcode =~ s/\n/\\n/g;
3090 3401
3402 %vars = (_dummy => 0) unless %vars;
3403
3404 my @res;
3091 local $_; 3405 local $_;
3092 local @safe::cf::_safe_eval_args = values %vars;
3093 3406
3094 my $eval = 3407 my $eval =
3095 "do {\n" 3408 "do {\n"
3096 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3409 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3097 . "#line 0 \"{$qcode}\"\n" 3410 . "#line 0 \"{$qcode}\"\n"
3098 . $code 3411 . $code
3099 . "\n}" 3412 . "\n}"
3100 ; 3413 ;
3101 3414
3415 if ($CFG{safe_eval}) {
3102 sub_generation_inc; 3416 sub_generation_inc;
3417 local @safe::cf::_safe_eval_args = values %vars;
3103 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3418 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3104 sub_generation_inc; 3419 sub_generation_inc;
3420 } else {
3421 local @cf::_safe_eval_args = values %vars;
3422 @res = wantarray ? eval eval : scalar eval $eval;
3423 }
3105 3424
3106 if ($@) { 3425 if ($@) {
3107 warn "$@"; 3426 warn "$@",
3108 warn "while executing safe code '$code'\n"; 3427 "while executing safe code '$code'\n",
3109 warn "with arguments " . (join " ", %vars) . "\n"; 3428 "with arguments " . (join " ", %vars) . "\n";
3110 } 3429 }
3111 3430
3112 wantarray ? @res : $res[0] 3431 wantarray ? @res : $res[0]
3113} 3432}
3114 3433
… …
3128=cut 3447=cut
3129 3448
3130sub register_script_function { 3449sub register_script_function {
3131 my ($fun, $cb) = @_; 3450 my ($fun, $cb) = @_;
3132 3451
3133 no strict 'refs'; 3452 $fun = "safe::$fun" if $CFG{safe_eval};
3134 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3453 *$fun = $safe_hole->wrap ($cb);
3135} 3454}
3136 3455
3137=back 3456=back
3138 3457
3139=cut 3458=cut
… …
3148 # for this (global event?) 3467 # for this (global event?)
3149 %ext::player_env::MUSIC_FACE_CACHE = (); 3468 %ext::player_env::MUSIC_FACE_CACHE = ();
3150 3469
3151 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3470 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3152 3471
3153 warn "loading facedata from $path\n"; 3472 trace "loading facedata from $path\n";
3154 3473
3155 my $facedata; 3474 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 3475
3161 $facedata->{version} == 2 3476 $facedata->{version} == 2
3162 or cf::cleanup "$path: version mismatch, cannot proceed."; 3477 or cf::cleanup "$path: version mismatch, cannot proceed.";
3163 3478
3164 # patch in the exptable 3479 # patch in the exptable
3480 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3165 $facedata->{resource}{"res/exp_table"} = { 3481 $facedata->{resource}{"res/exp_table"} = {
3166 type => FT_RSRC, 3482 type => FT_RSRC,
3167 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3483 data => $exp_table,
3484 hash => (Digest::MD5::md5 $exp_table),
3168 }; 3485 };
3169 cf::cede_to_tick; 3486 cf::cede_to_tick;
3170 3487
3171 { 3488 {
3172 my $faces = $facedata->{faceinfo}; 3489 my $faces = $facedata->{faceinfo};
… …
3174 while (my ($face, $info) = each %$faces) { 3491 while (my ($face, $info) = each %$faces) {
3175 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3492 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3176 3493
3177 cf::face::set_visibility $idx, $info->{visibility}; 3494 cf::face::set_visibility $idx, $info->{visibility};
3178 cf::face::set_magicmap $idx, $info->{magicmap}; 3495 cf::face::set_magicmap $idx, $info->{magicmap};
3179 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3496 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3180 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3497 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3498 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3181 3499
3182 cf::cede_to_tick; 3500 cf::cede_to_tick;
3183 } 3501 }
3184 3502
3185 while (my ($face, $info) = each %$faces) { 3503 while (my ($face, $info) = each %$faces) {
… …
3190 3508
3191 if (my $smooth = cf::face::find $info->{smooth}) { 3509 if (my $smooth = cf::face::find $info->{smooth}) {
3192 cf::face::set_smooth $idx, $smooth; 3510 cf::face::set_smooth $idx, $smooth;
3193 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3511 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3194 } else { 3512 } else {
3195 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3513 error "smooth face '$info->{smooth}' not found for face '$face'";
3196 } 3514 }
3197 3515
3198 cf::cede_to_tick; 3516 cf::cede_to_tick;
3199 } 3517 }
3200 } 3518 }
… …
3209 3527
3210 cf::anim::invalidate_all; # d'oh 3528 cf::anim::invalidate_all; # d'oh
3211 } 3529 }
3212 3530
3213 { 3531 {
3214 # TODO: for gcfclient pleasure, we should give resources
3215 # that gcfclient doesn't grok a >10000 face index.
3216 my $res = $facedata->{resource}; 3532 my $res = $facedata->{resource};
3217 3533
3218 while (my ($name, $info) = each %$res) { 3534 while (my ($name, $info) = each %$res) {
3219 if (defined $info->{type}) { 3535 if (defined $info->{type}) {
3220 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3536 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3221 my $data;
3222 3537
3223 if ($info->{type} & 1) { 3538 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}; 3539 cf::face::set_type $idx, $info->{type};
3238 } else { 3540 } else {
3239 $RESOURCE{$name} = $info; 3541 $RESOURCE{$name} = $info; # unused
3240 } 3542 }
3241 3543
3242 cf::cede_to_tick; 3544 cf::cede_to_tick;
3243 } 3545 }
3244 } 3546 }
3245 3547
3246 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3548 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3247 3549
3248 1 3550 1
3249} 3551}
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 3552
3271register_exticmd fx_want => sub { 3553register_exticmd fx_want => sub {
3272 my ($ns, $want) = @_; 3554 my ($ns, $want) = @_;
3273 3555
3274 while (my ($k, $v) = each %$want) { 3556 while (my ($k, $v) = each %$want) {
… …
3313sub reload_treasures { 3595sub reload_treasures {
3314 load_resource_file "$DATADIR/treasures" 3596 load_resource_file "$DATADIR/treasures"
3315 or die "unable to load treasurelists\n"; 3597 or die "unable to load treasurelists\n";
3316} 3598}
3317 3599
3600sub reload_sound {
3601 trace "loading sound config from $DATADIR/sound\n";
3602
3603 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3604
3605 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3606 my $sound = $soundconf->{compat}[$_]
3607 or next;
3608
3609 my $face = cf::face::find "sound/$sound->[1]";
3610 cf::sound::set $sound->[0] => $face;
3611 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3612 }
3613
3614 while (my ($k, $v) = each %{$soundconf->{event}}) {
3615 my $face = cf::face::find "sound/$v";
3616 cf::sound::set $k => $face;
3617 }
3618}
3619
3318sub reload_resources { 3620sub reload_resources {
3319 warn "reloading resource files...\n"; 3621 trace "reloading resource files...\n";
3320 3622
3623 reload_exp_table;
3624 reload_materials;
3321 reload_facedata; 3625 reload_facedata;
3626 reload_sound;
3322 reload_archetypes; 3627 reload_archetypes;
3323 reload_regions; 3628 reload_regions;
3324 reload_treasures; 3629 reload_treasures;
3325 3630
3326 warn "finished reloading resource files\n"; 3631 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} 3632}
3336 3633
3337sub reload_config { 3634sub reload_config {
3338 open my $fh, "<:utf8", "$CONFDIR/config" 3635 trace "reloading config file...\n";
3339 or return;
3340 3636
3341 local $/; 3637 my $config = load_file "$CONFDIR/config";
3342 *CFG = YAML::Load <$fh>; 3638 utf8::decode $config;
3639 *CFG = decode_yaml $config;
3343 3640
3344 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3641 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3345 3642
3346 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3643 $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}; 3644 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3348 3645
3349 if (exists $CFG{mlockall}) { 3646 if (exists $CFG{mlockall}) {
… …
3353 }; 3650 };
3354 warn $@ if $@; 3651 warn $@ if $@;
3355 } 3652 }
3356} 3653}
3357 3654
3655sub pidfile() {
3656 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3657 or die "$PIDFILE: $!";
3658 flock $fh, &Fcntl::LOCK_EX
3659 or die "$PIDFILE: flock: $!";
3660 $fh
3661}
3662
3663# make sure only one server instance is running at any one time
3664sub atomic {
3665 my $fh = pidfile;
3666
3667 my $pid = <$fh>;
3668 kill 9, $pid if $pid > 0;
3669
3670 seek $fh, 0, 0;
3671 print $fh $$;
3672}
3673
3674sub main_loop {
3675 trace "EV::loop starting\n";
3676 if (1) {
3677 EV::loop;
3678 }
3679 trace "EV::loop returned\n";
3680 goto &main_loop unless $REALLY_UNLOOP;
3681}
3682
3358sub main { 3683sub main {
3684 cf::init_globals; # initialise logging
3685
3686 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3687 LOG llevInfo, "Copyright (C) 2005-2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3688 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3689 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3690
3691 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3692
3359 # we must not ever block the main coroutine 3693 # we must not ever block the main coroutine
3360 local $Coro::idle = sub { 3694 local $Coro::idle = sub {
3361 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3695 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3362 (async { 3696 (async {
3363 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3697 $Coro::current->{desc} = "IDLE BUG HANDLER";
3364 EV::loop EV::LOOP_ONESHOT; 3698 EV::loop EV::LOOP_ONESHOT;
3365 })->prio (Coro::PRIO_MAX); 3699 })->prio (Coro::PRIO_MAX);
3366 }; 3700 };
3367 3701
3368 { 3702 evthread_start IO::AIO::poll_fileno;
3369 my $guard = freeze_mainloop; 3703
3704 cf::sync_job {
3705 cf::incloader::init ();
3706
3707 cf::init_anim;
3708 cf::init_attackmess;
3709 cf::init_dynamic;
3710
3711 cf::load_settings;
3712
3713 reload_resources;
3370 reload_config; 3714 reload_config;
3371 db_init; 3715 db_init;
3716
3717 cf::init_uuid;
3718 cf::init_signals;
3719 cf::init_skills;
3720
3721 cf::init_beforeplay;
3722
3723 atomic;
3724
3372 load_extensions; 3725 load_extensions;
3373 3726
3374 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3727 utime time, time, $RUNTIMEFILE;
3728
3729 # no (long-running) fork's whatsoever before this point(!)
3730 use POSIX ();
3731 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3732
3733 cf::_post_init 0;
3375 } 3734 };
3376 3735
3377 EV::loop; 3736 cf::object::thawer::errors_are_fatal 0;
3737 info "parse errors in files are no longer fatal from this point on.\n";
3738
3739 my $free_main; $free_main = EV::idle sub {
3740 undef $free_main;
3741 undef &main; # free gobs of memory :)
3742 };
3743
3744 goto &main_loop;
3378} 3745}
3379 3746
3380############################################################################# 3747#############################################################################
3381# initialisation and cleanup 3748# initialisation and cleanup
3382 3749
3383# install some emergency cleanup handlers 3750# install some emergency cleanup handlers
3384BEGIN { 3751BEGIN {
3385 our %SIGWATCHER = (); 3752 our %SIGWATCHER = ();
3386 for my $signal (qw(INT HUP TERM)) { 3753 for my $signal (qw(INT HUP TERM)) {
3387 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3754 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3388 cf::cleanup "SIG$signal"; 3755 cf::cleanup "SIG$signal";
3389 }; 3756 };
3390 } 3757 }
3391} 3758}
3392 3759
3393sub write_runtime_sync { 3760sub write_runtime_sync {
3394 my $runtime = "$LOCALDIR/runtime"; 3761 my $t0 = AE::time;
3395 3762
3396 # first touch the runtime file to show we are still running: 3763 # first touch the runtime file to show we are still running:
3397 # the fsync below can take a very very long time. 3764 # the fsync below can take a very very long time.
3398 3765
3399 IO::AIO::aio_utime $runtime, undef, undef; 3766 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3400 3767
3401 my $guard = cf::lock_acquire "write_runtime"; 3768 my $guard = cf::lock_acquire "write_runtime";
3402 3769
3403 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3770 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3404 or return; 3771 or return;
3405 3772
3406 my $value = $cf::RUNTIME + 90 + 10; 3773 my $value = $cf::RUNTIME + 90 + 10;
3407 # 10 is the runtime save interval, for a monotonic clock 3774 # 10 is the runtime save interval, for a monotonic clock
3408 # 60 allows for the watchdog to kill the server. 3775 # 60 allows for the watchdog to kill the server.
… …
3418 aio_utime $fh, undef, undef; 3785 aio_utime $fh, undef, undef;
3419 3786
3420 close $fh 3787 close $fh
3421 or return; 3788 or return;
3422 3789
3423 aio_rename "$runtime~", $runtime 3790 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3424 and return; 3791 and return;
3425 3792
3426 warn "runtime file written.\n"; 3793 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3427 3794
3428 1 3795 1
3429} 3796}
3430 3797
3431our $uuid_lock; 3798our $uuid_lock;
… …
3440 my $uuid = "$LOCALDIR/uuid"; 3807 my $uuid = "$LOCALDIR/uuid";
3441 3808
3442 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 3809 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3443 or return; 3810 or return;
3444 3811
3445 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; 3812 my $value = uuid_seq uuid_cur;
3813
3814 unless ($value) {
3815 info "cowardly refusing to write zero uuid value!\n";
3816 return;
3817 }
3818
3819 my $value = uuid_str $value + $uuid_skip;
3446 $uuid_skip = 0; 3820 $uuid_skip = 0;
3447 3821
3448 (aio_write $fh, 0, (length $value), $value, 0) <= 0 3822 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3449 and return; 3823 and return;
3450 3824
… …
3456 or return; 3830 or return;
3457 3831
3458 aio_rename "$uuid~", $uuid 3832 aio_rename "$uuid~", $uuid
3459 and return; 3833 and return;
3460 3834
3461 warn "uuid file written ($value).\n"; 3835 trace "uuid file written ($value).\n";
3462 3836
3463 1 3837 1
3464 3838
3465} 3839}
3466 3840
… …
3472} 3846}
3473 3847
3474sub emergency_save() { 3848sub emergency_save() {
3475 my $freeze_guard = cf::freeze_mainloop; 3849 my $freeze_guard = cf::freeze_mainloop;
3476 3850
3477 warn "enter emergency perl save\n"; 3851 info "emergency_perl_save: enter\n";
3852
3853 # this is a trade-off: we want to be very quick here, so
3854 # save all maps without fsync, and later call a global sync
3855 # (which in turn might be very very slow)
3856 local $USE_FSYNC = 0;
3478 3857
3479 cf::sync_job { 3858 cf::sync_job {
3859 cf::write_runtime_sync; # external watchdog should not bark
3860
3480 # use a peculiar iteration method to avoid tripping on perl 3861 # use a peculiar iteration method to avoid tripping on perl
3481 # refcount bugs in for. also avoids problems with players 3862 # refcount bugs in for. also avoids problems with players
3482 # and maps saved/destroyed asynchronously. 3863 # and maps saved/destroyed asynchronously.
3483 warn "begin emergency player save\n"; 3864 info "emergency_perl_save: begin player save\n";
3484 for my $login (keys %cf::PLAYER) { 3865 for my $login (keys %cf::PLAYER) {
3485 my $pl = $cf::PLAYER{$login} or next; 3866 my $pl = $cf::PLAYER{$login} or next;
3486 $pl->valid or next; 3867 $pl->valid or next;
3487 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3868 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3488 $pl->save; 3869 $pl->save;
3489 } 3870 }
3490 warn "end emergency player save\n"; 3871 info "emergency_perl_save: end player save\n";
3491 3872
3492 warn "begin emergency map save\n"; 3873 cf::write_runtime_sync; # external watchdog should not bark
3874
3875 info "emergency_perl_save: begin map save\n";
3493 for my $path (keys %cf::MAP) { 3876 for my $path (keys %cf::MAP) {
3494 my $map = $cf::MAP{$path} or next; 3877 my $map = $cf::MAP{$path} or next;
3495 $map->valid or next; 3878 $map->valid or next;
3496 $map->save; 3879 $map->save;
3497 } 3880 }
3498 warn "end emergency map save\n"; 3881 info "emergency_perl_save: end map save\n";
3499 3882
3500 warn "begin emergency database checkpoint\n"; 3883 cf::write_runtime_sync; # external watchdog should not bark
3884
3885 info "emergency_perl_save: begin database checkpoint\n";
3501 BDB::db_env_txn_checkpoint $DB_ENV; 3886 BDB::db_env_txn_checkpoint $DB_ENV;
3502 warn "end emergency database checkpoint\n"; 3887 info "emergency_perl_save: end database checkpoint\n";
3503 3888
3504 warn "begin write uuid\n"; 3889 info "emergency_perl_save: begin write uuid\n";
3505 write_uuid_sync 1; 3890 write_uuid_sync 1;
3506 warn "end write uuid\n"; 3891 info "emergency_perl_save: end write uuid\n";
3892
3893 cf::write_runtime_sync; # external watchdog should not bark
3894
3895 trace "emergency_perl_save: syncing database to disk";
3896 BDB::db_env_txn_checkpoint $DB_ENV;
3897
3898 info "emergency_perl_save: starting sync\n";
3899 IO::AIO::aio_sync sub {
3900 info "emergency_perl_save: finished sync\n";
3901 };
3902
3903 cf::write_runtime_sync; # external watchdog should not bark
3904
3905 trace "emergency_perl_save: flushing outstanding aio requests";
3906 while (IO::AIO::nreqs || BDB::nreqs) {
3907 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3908 }
3909
3910 cf::write_runtime_sync; # external watchdog should not bark
3507 }; 3911 };
3508 3912
3509 warn "leave emergency perl save\n"; 3913 info "emergency_perl_save: leave\n";
3510} 3914}
3511 3915
3512sub post_cleanup { 3916sub post_cleanup {
3513 my ($make_core) = @_; 3917 my ($make_core) = @_;
3514 3918
3919 IO::AIO::flush;
3920
3515 warn Carp::longmess "post_cleanup backtrace" 3921 error Carp::longmess "post_cleanup backtrace"
3516 if $make_core; 3922 if $make_core;
3923
3924 my $fh = pidfile;
3925 unlink $PIDFILE if <$fh> == $$;
3517} 3926}
3518 3927
3519# a safer delete_package, copied from Symbol 3928# a safer delete_package, copied from Symbol
3520sub clear_package($) { 3929sub clear_package($) {
3521 my $pkg = shift; 3930 my $pkg = shift;
… …
3537 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3946 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3538 for my $name (keys %$leaf_symtab) { 3947 for my $name (keys %$leaf_symtab) {
3539 _gv_clear *{"$pkg$name"}; 3948 _gv_clear *{"$pkg$name"};
3540# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3949# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3541 } 3950 }
3542 warn "cleared package #$pkg\n";#d#
3543} 3951}
3544
3545our $RELOAD; # how many times to reload
3546 3952
3547sub do_reload_perl() { 3953sub do_reload_perl() {
3548 # can/must only be called in main 3954 # can/must only be called in main
3549 if ($Coro::current != $Coro::main) { 3955 unless (in_main) {
3550 warn "can only reload from main coroutine"; 3956 error "can only reload from main coroutine";
3551 return; 3957 return;
3552 } 3958 }
3553 3959
3554 return if $RELOAD++; 3960 return if $RELOAD++;
3555 3961
3962 my $t1 = AE::time;
3963
3556 while ($RELOAD) { 3964 while ($RELOAD) {
3557 warn "reloading..."; 3965 cf::get_slot 0.1, -1, "reload_perl";
3966 info "perl_reload: reloading...";
3558 3967
3559 warn "entering sync_job"; 3968 trace "perl_reload: entering sync_job";
3560 3969
3561 cf::sync_job { 3970 cf::sync_job {
3562 cf::write_runtime_sync; # external watchdog should not bark
3563 cf::emergency_save; 3971 #cf::emergency_save;
3564 cf::write_runtime_sync; # external watchdog should not bark
3565 3972
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"; 3973 trace "perl_reload: cancelling all extension coros";
3577 $_->cancel for values %EXT_CORO; 3974 $_->cancel for values %EXT_CORO;
3578 %EXT_CORO = (); 3975 %EXT_CORO = ();
3579 3976
3580 warn "removing commands"; 3977 trace "perl_reload: removing commands";
3581 %COMMAND = (); 3978 %COMMAND = ();
3582 3979
3583 warn "removing ext/exti commands"; 3980 trace "perl_reload: removing ext/exti commands";
3584 %EXTCMD = (); 3981 %EXTCMD = ();
3585 %EXTICMD = (); 3982 %EXTICMD = ();
3586 3983
3587 warn "unloading/nuking all extensions"; 3984 trace "perl_reload: unloading/nuking all extensions";
3588 for my $pkg (@EXTS) { 3985 for my $pkg (@EXTS) {
3589 warn "... unloading $pkg"; 3986 trace "... unloading $pkg";
3590 3987
3591 if (my $cb = $pkg->can ("unload")) { 3988 if (my $cb = $pkg->can ("unload")) {
3592 eval { 3989 eval {
3593 $cb->($pkg); 3990 $cb->($pkg);
3594 1 3991 1
3595 } or warn "$pkg unloaded, but with errors: $@"; 3992 } or error "$pkg unloaded, but with errors: $@";
3596 } 3993 }
3597 3994
3598 warn "... clearing $pkg"; 3995 trace "... clearing $pkg";
3599 clear_package $pkg; 3996 clear_package $pkg;
3600 } 3997 }
3601 3998
3602 warn "unloading all perl modules loaded from $LIBDIR"; 3999 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3603 while (my ($k, $v) = each %INC) { 4000 while (my ($k, $v) = each %INC) {
3604 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 4001 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3605 4002
3606 warn "... unloading $k"; 4003 trace "... unloading $k";
3607 delete $INC{$k}; 4004 delete $INC{$k};
3608 4005
3609 $k =~ s/\.pm$//; 4006 $k =~ s/\.pm$//;
3610 $k =~ s/\//::/g; 4007 $k =~ s/\//::/g;
3611 4008
… …
3614 } 4011 }
3615 4012
3616 clear_package $k; 4013 clear_package $k;
3617 } 4014 }
3618 4015
3619 warn "getting rid of safe::, as good as possible"; 4016 trace "perl_reload: getting rid of safe::, as good as possible";
3620 clear_package "safe::$_" 4017 clear_package "safe::$_"
3621 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 4018 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3622 4019
3623 warn "unloading cf.pm \"a bit\""; 4020 trace "perl_reload: unloading cf.pm \"a bit\"";
3624 delete $INC{"cf.pm"}; 4021 delete $INC{"cf.pm"};
3625 delete $INC{"cf/pod.pm"}; 4022 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3626 4023
3627 # don't, removes xs symbols, too, 4024 # don't, removes xs symbols, too,
3628 # and global variables created in xs 4025 # and global variables created in xs
3629 #clear_package __PACKAGE__; 4026 #clear_package __PACKAGE__;
3630 4027
3631 warn "unload completed, starting to reload now"; 4028 info "perl_reload: unload completed, starting to reload now";
3632 4029
3633 warn "reloading cf.pm"; 4030 trace "perl_reload: reloading cf.pm";
3634 require cf; 4031 require cf;
3635 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 4032 cf::_connect_to_perl_1;
3636 4033
3637 warn "loading config and database again"; 4034 trace "perl_reload: loading config and database again";
3638 cf::reload_config; 4035 cf::reload_config;
3639 4036
3640 warn "loading extensions"; 4037 trace "perl_reload: loading extensions";
3641 cf::load_extensions; 4038 cf::load_extensions;
3642 4039
4040 if ($REATTACH_ON_RELOAD) {
3643 warn "reattaching attachments to objects/players"; 4041 trace "perl_reload: reattaching attachments to objects/players";
3644 _global_reattach; # objects, sockets 4042 _global_reattach; # objects, sockets
3645 warn "reattaching attachments to maps"; 4043 trace "perl_reload: reattaching attachments to maps";
3646 reattach $_ for values %MAP; 4044 reattach $_ for values %MAP;
3647 warn "reattaching attachments to players"; 4045 trace "perl_reload: reattaching attachments to players";
3648 reattach $_ for values %PLAYER; 4046 reattach $_ for values %PLAYER;
4047 }
3649 4048
3650 warn "leaving sync_job"; 4049 cf::_post_init 1;
4050
4051 trace "perl_reload: leaving sync_job";
3651 4052
3652 1 4053 1
3653 } or do { 4054 } or do {
3654 warn $@; 4055 error $@;
3655 cf::cleanup "error while reloading, exiting."; 4056 cf::cleanup "perl_reload: error, exiting.";
3656 }; 4057 };
3657 4058
3658 warn "reloaded";
3659 --$RELOAD; 4059 --$RELOAD;
3660 } 4060 }
4061
4062 $t1 = AE::time - $t1;
4063 info "perl_reload: completed in ${t1}s\n";
3661}; 4064};
3662 4065
3663our $RELOAD_WATCHER; # used only during reload 4066our $RELOAD_WATCHER; # used only during reload
3664 4067
3665sub reload_perl() { 4068sub reload_perl() {
3666 # doing reload synchronously and two reloads happen back-to-back, 4069 # doing reload synchronously and two reloads happen back-to-back,
3667 # coro crashes during coro_state_free->destroy here. 4070 # coro crashes during coro_state_free->destroy here.
3668 4071
4072 $RELOAD_WATCHER ||= cf::async {
4073 Coro::AIO::aio_wait cache_extensions;
4074
3669 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 4075 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3670 do_reload_perl; 4076 do_reload_perl;
3671 undef $RELOAD_WATCHER; 4077 undef $RELOAD_WATCHER;
4078 };
3672 }; 4079 };
3673} 4080}
3674 4081
3675register_command "reload" => sub { 4082register_command "reload" => sub {
3676 my ($who, $arg) = @_; 4083 my ($who, $arg) = @_;
… …
3682 reload_perl; 4089 reload_perl;
3683 }; 4090 };
3684 } 4091 }
3685}; 4092};
3686 4093
3687unshift @INC, $LIBDIR; 4094#############################################################################
3688 4095
3689my $bug_warning = 0; 4096my $bug_warning = 0;
3690 4097
3691our @WAIT_FOR_TICK; 4098our @WAIT_FOR_TICK;
3692our @WAIT_FOR_TICK_BEGIN; 4099our @WAIT_FOR_TICK_BEGIN;
3693 4100
3694sub wait_for_tick { 4101sub wait_for_tick() {
3695 return if tick_inhibit || $Coro::current == $Coro::main; 4102 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3696 4103
3697 my $signal = new Coro::Signal; 4104 my $signal = new Coro::Signal;
3698 push @WAIT_FOR_TICK, $signal; 4105 push @WAIT_FOR_TICK, $signal;
3699 $signal->wait; 4106 $signal->wait;
3700} 4107}
3701 4108
3702sub wait_for_tick_begin { 4109sub wait_for_tick_begin() {
3703 return if tick_inhibit || $Coro::current == $Coro::main; 4110 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3704 4111
3705 my $signal = new Coro::Signal; 4112 my $signal = new Coro::Signal;
3706 push @WAIT_FOR_TICK_BEGIN, $signal; 4113 push @WAIT_FOR_TICK_BEGIN, $signal;
3707 $signal->wait; 4114 $signal->wait;
3708} 4115}
… …
3714 return; 4121 return;
3715 } 4122 }
3716 4123
3717 cf::server_tick; # one server iteration 4124 cf::server_tick; # one server iteration
3718 4125
4126 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4127
3719 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4128 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3720 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4129 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3721 Coro::async_pool { 4130 Coro::async_pool {
3722 $Coro::current->{desc} = "runtime saver"; 4131 $Coro::current->{desc} = "runtime saver";
3723 write_runtime_sync 4132 write_runtime_sync
3724 or warn "ERROR: unable to write runtime file: $!"; 4133 or error "ERROR: unable to write runtime file: $!";
3725 }; 4134 };
3726 } 4135 }
3727 4136
3728 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4137 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3729 $sig->send; 4138 $sig->send;
… …
3737 4146
3738 if (0) { 4147 if (0) {
3739 if ($NEXT_TICK) { 4148 if ($NEXT_TICK) {
3740 my $jitter = $TICK_START - $NEXT_TICK; 4149 my $jitter = $TICK_START - $NEXT_TICK;
3741 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4150 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3742 warn "jitter $JITTER\n";#d# 4151 debug "jitter $JITTER\n";#d#
3743 } 4152 }
3744 } 4153 }
3745} 4154}
3746 4155
3747{ 4156{
3748 # configure BDB 4157 # configure BDB
3749 4158
3750 BDB::min_parallel 8; 4159 BDB::min_parallel 16;
3751 BDB::max_poll_reqs $TICK * 0.1; 4160 BDB::max_poll_reqs $TICK * 0.1;
3752 $AnyEvent::BDB::WATCHER->priority (1); 4161 $AnyEvent::BDB::WATCHER->priority (1);
3753 4162
3754 unless ($DB_ENV) { 4163 unless ($DB_ENV) {
3755 $DB_ENV = BDB::db_env_create; 4164 $DB_ENV = BDB::db_env_create;
… …
3792 IO::AIO::min_parallel 8; 4201 IO::AIO::min_parallel 8;
3793 IO::AIO::max_poll_time $TICK * 0.1; 4202 IO::AIO::max_poll_time $TICK * 0.1;
3794 undef $AnyEvent::AIO::WATCHER; 4203 undef $AnyEvent::AIO::WATCHER;
3795} 4204}
3796 4205
3797my $_log_backtrace; 4206our $_log_backtrace;
4207our $_log_backtrace_last;
3798 4208
3799sub _log_backtrace { 4209sub _log_backtrace {
3800 my ($msg, @addr) = @_; 4210 my ($msg, @addr) = @_;
3801 4211
3802 $msg =~ s/\n//; 4212 $msg =~ s/\n$//;
3803 4213
4214 if ($_log_backtrace_last eq $msg) {
4215 LOG llevInfo, "[ABT] $msg\n";
4216 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3804 # limit the # of concurrent backtraces 4217 # limit the # of concurrent backtraces
3805 if ($_log_backtrace < 2) { 4218 } elsif ($_log_backtrace < 2) {
4219 $_log_backtrace_last = $msg;
3806 ++$_log_backtrace; 4220 ++$_log_backtrace;
4221 my $perl_bt = Carp::longmess $msg;
3807 async { 4222 async {
3808 $Coro::current->{desc} = "abt $msg"; 4223 $Coro::current->{desc} = "abt $msg";
3809 4224
3810 my @bt = fork_call { 4225 my @bt = fork_call {
3811 @addr = map { sprintf "%x", $_ } @addr; 4226 @addr = map { sprintf "%x", $_ } @addr;
… …
3822 } 4237 }
3823 4238
3824 @funcs 4239 @funcs
3825 }; 4240 };
3826 4241
3827 LOG llevInfo, "[ABT] $msg\n"; 4242 LOG llevInfo, "[ABT] $perl_bt\n";
4243 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3828 LOG llevInfo, "[ABT] $_\n" for @bt; 4244 LOG llevInfo, "[ABT] $_\n" for @bt;
3829 --$_log_backtrace; 4245 --$_log_backtrace;
3830 }; 4246 };
3831 } else { 4247 } else {
3832 LOG llevInfo, "[ABT] $msg\n"; 4248 LOG llevInfo, "[ABT] $msg\n";
3833 LOG llevInfo, "[ABT] [suppressed]\n"; 4249 LOG llevInfo, "[ABT] [overload, suppressed]\n";
3834 } 4250 }
3835} 4251}
3836 4252
3837# load additional modules 4253# load additional modules
3838use cf::pod; 4254require "cf/$_.pm" for @EXTRA_MODULES;
4255cf::_connect_to_perl_2;
3839 4256
3840END { cf::emergency_save } 4257END { cf::emergency_save }
3841 4258
38421 42591
3843 4260

Diff Legend

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