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.428 by root, Thu May 1 06:33:19 2008 UTC vs.
Revision 1.560 by root, Fri Apr 22 02:03:12 2011 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify 6# Deliantra is free software: you can redistribute it and/or modify it under
7# it under the terms of the GNU General Public License as published by 7# the terms of the Affero GNU General Public License as published by the
8# the Free Software Foundation, either version 3 of the License, or 8# Free Software Foundation, either version 3 of the License, or (at your
9# (at your option) any later version. 9# option) any later version.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>. 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
18# 19#
19# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
20# 21#
21 22
22package cf; 23package cf;
23 24
24use utf8; 25use common::sense;
25use strict;
26 26
27use Symbol; 27use Symbol;
28use List::Util; 28use List::Util;
29use Socket; 29use Socket;
30use EV 3.2; 30use EV;
31use Opcode; 31use Opcode;
32use Safe; 32use Safe;
33use Safe::Hole; 33use Safe::Hole;
34use Storable (); 34use Storable ();
35use Carp ();
35 36
37use Guard ();
36use Coro 4.50 (); 38use Coro ();
37use Coro::State; 39use Coro::State;
38use Coro::Handle; 40use Coro::Handle;
39use Coro::EV; 41use Coro::EV;
42use Coro::AnyEvent;
40use Coro::Timer; 43use Coro::Timer;
41use Coro::Signal; 44use Coro::Signal;
42use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
43use Coro::AIO; 48use Coro::AIO;
44use Coro::BDB; 49use Coro::BDB 1.6;
45use Coro::Storable; 50use Coro::Storable;
46use Coro::Util (); 51use Coro::Util ();
47 52
48use JSON::XS 2.01 (); 53use JSON::XS 2.01 ();
49use BDB (); 54use BDB ();
50use Data::Dumper; 55use Data::Dumper;
51use Digest::MD5;
52use Fcntl; 56use Fcntl;
53use YAML (); 57use YAML::XS ();
54use IO::AIO 2.51 (); 58use IO::AIO ();
55use Time::HiRes; 59use Time::HiRes;
56use Compress::LZF; 60use Compress::LZF;
57use Digest::MD5 (); 61use Digest::MD5 ();
62
63AnyEvent::detect;
58 64
59# configure various modules to our taste 65# configure various modules to our taste
60# 66#
61$Storable::canonical = 1; # reduce rsync transfers 67$Storable::canonical = 1; # reduce rsync transfers
62Coro::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";
63Compress::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
64 75
65$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" };
66 78
67sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
80
81our @ORIG_INC;
68 82
69our %COMMAND = (); 83our %COMMAND = ();
70our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
71 85
72our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
73our %EXTCMD = (); 87our %EXTCMD = ();
74our %EXTICMD = (); 88our %EXTICMD = ();
75our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
76our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
77 91
78our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
79our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
80 96
81our $CONFDIR = confdir; 97our $CONFDIR = confdir;
98
82our $DATADIR = datadir; 99our $DATADIR = datadir;
83our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
84our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
85our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
103
86our $LOCALDIR = localdir; 104our $LOCALDIR = localdir;
87our $TMPDIR = "$LOCALDIR/" . tmpdir; 105our $TMPDIR = "$LOCALDIR/" . tmpdir;
88our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 106our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
89our $PLAYERDIR = "$LOCALDIR/" . playerdir; 107our $PLAYERDIR = "$LOCALDIR/" . playerdir;
90our $RANDOMDIR = "$LOCALDIR/random"; 108our $RANDOMDIR = "$LOCALDIR/random";
91our $BDBDIR = "$LOCALDIR/db"; 109our $BDBDIR = "$LOCALDIR/db";
110our $PIDFILE = "$LOCALDIR/pid";
111our $RUNTIMEFILE = "$LOCALDIR/runtime";
112
92our %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;
93 120
94our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 121our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
95our $AIO_POLL_WATCHER;
96our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 122our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
97our $NEXT_TICK; 123our $NEXT_TICK;
98our $USE_FSYNC = 1; # use fsync to write maps - default off 124our $USE_FSYNC = 1; # use fsync to write maps - default on
99 125
100our $BDB_POLL_WATCHER;
101our $BDB_DEADLOCK_WATCHER; 126our $BDB_DEADLOCK_WATCHER;
102our $BDB_CHECKPOINT_WATCHER; 127our $BDB_CHECKPOINT_WATCHER;
103our $BDB_TRICKLE_WATCHER; 128our $BDB_TRICKLE_WATCHER;
104our $DB_ENV; 129our $DB_ENV;
105 130
131our @EXTRA_MODULES = qw(pod match mapscript incloader);
132
106our %CFG; 133our %CFG;
107 134
108our $UPTIME; $UPTIME ||= time; 135our $UPTIME; $UPTIME ||= time;
109our $RUNTIME; 136our $RUNTIME;
110our $NOW; 137our $NOW;
119our $LOAD; # a number between 0 (idle) and 1 (too many objects) 146our $LOAD; # a number between 0 (idle) and 1 (too many objects)
120our $LOADAVG; # same thing, but with alpha-smoothing 147our $LOADAVG; # same thing, but with alpha-smoothing
121our $JITTER; # average jitter 148our $JITTER; # average jitter
122our $TICK_START; # for load detecting purposes 149our $TICK_START; # for load detecting purposes
123 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
124binmode STDOUT; 156binmode STDOUT;
125binmode STDERR; 157binmode STDERR;
126 158
127# read virtual server time, if available 159# read virtual server time, if available
128unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 160unless ($RUNTIME || !-e $RUNTIMEFILE) {
129 open my $fh, "<", "$LOCALDIR/runtime" 161 open my $fh, "<", $RUNTIMEFILE
130 or die "unable to read runtime file: $!"; 162 or die "unable to read $RUNTIMEFILE file: $!";
131 $RUNTIME = <$fh> + 0.; 163 $RUNTIME = <$fh> + 0.;
132} 164}
165
166eval "sub TICK() { $TICK } 1" or die;
133 167
134mkdir $_ 168mkdir $_
135 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 169 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
136 170
137our $EMERGENCY_POSITION; 171our $EMERGENCY_POSITION;
138 172
139sub 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::"} };
140 189
141############################################################################# 190#############################################################################
142 191
143=head2 GLOBAL VARIABLES 192=head2 GLOBAL VARIABLES
144 193
186from wherever your confdir points to. 235from wherever your confdir points to.
187 236
188=item cf::wait_for_tick, cf::wait_for_tick_begin 237=item cf::wait_for_tick, cf::wait_for_tick_begin
189 238
190These 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
191returns 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
192per 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.
193 242
243=cut
244
245sub wait_for_tick();
246sub wait_for_tick_begin();
247
194=item @cf::INVOKE_RESULTS 248=item @cf::INVOKE_RESULTS
195 249
196This array contains the results of the last C<invoke ()> call. When 250This array contains the results of the last C<invoke ()> call. When
197C<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
198that call. 252that call.
199 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
200=back 260=back
201 261
202=cut 262=cut
203 263
204BEGIN { 264sub error(@) { LOG llevError, join "", @_ }
205 *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 {
206 my $msg = join "", @_; 271 my $msg = join "", @_;
207 272
208 $msg .= "\n" 273 $msg .= "\n"
209 unless $msg =~ /\n$/; 274 unless $msg =~ /\n$/;
210 275
211 $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;
212 277
213 LOG llevError, $msg; 278 LOG llevWarn, $msg;
214 }; 279};
215}
216 280
217$Coro::State::DIEHOOK = sub { 281$Coro::State::DIEHOOK = sub {
218 return unless $^S eq 0; # "eq", not "==" 282 return unless $^S eq 0; # "eq", not "=="
219 283
220 if ($Coro::current == $Coro::main) {#d# 284 error Carp::longmess $_[0];
285
286 if (in_main) {#d#
221 warn "DIEHOOK called in main context, Coro bug?\n";#d# 287 error "DIEHOOK called in main context, Coro bug?\n";#d#
222 return;#d# 288 return;#d#
223 }#d# 289 }#d#
224 290
225 # kill coroutine otherwise 291 # kill coroutine otherwise
226 warn Carp::longmess $_[0];
227 Coro::terminate 292 Coro::terminate
228}; 293};
229
230$SIG{__DIE__} = sub { }; #d#?
231 294
232@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 295@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
233@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 296@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
234@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 297@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
235@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 298@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
242for my $pkg (qw( 305for my $pkg (qw(
243 cf::global cf::attachable 306 cf::global cf::attachable
244 cf::object cf::object::player 307 cf::object cf::object::player
245 cf::client cf::player 308 cf::client cf::player
246 cf::arch cf::living 309 cf::arch cf::living
310 cf::map cf::mapspace
247 cf::map cf::party cf::region 311 cf::party cf::region
248)) { 312)) {
249 no strict 'refs';
250 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 313 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
251} 314}
252 315
253$EV::DIED = sub { 316$EV::DIED = sub {
254 warn "error in event callback: @_"; 317 Carp::cluck "error in event callback: @_";
255}; 318};
319
320#############################################################################
321
322sub fork_call(&@);
323sub get_slot($;$$);
256 324
257############################################################################# 325#############################################################################
258 326
259=head2 UTILITY FUNCTIONS 327=head2 UTILITY FUNCTIONS
260 328
281 $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;
282 $d 350 $d
283 } || "[unable to dump $_[0]: '$@']"; 351 } || "[unable to dump $_[0]: '$@']";
284} 352}
285 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
286=item $ref = cf::decode_json $json 368=item $ref = cf::decode_json $json
287 369
288Converts a JSON string into the corresponding perl data structure. 370Converts a JSON string into the corresponding perl data structure.
289 371
290=item $json = cf::encode_json $ref 372=item $json = cf::encode_json $ref
296our $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
297 379
298sub encode_json($) { $json_coder->encode ($_[0]) } 380sub encode_json($) { $json_coder->encode ($_[0]) }
299sub decode_json($) { $json_coder->decode ($_[0]) } 381sub decode_json($) { $json_coder->decode ($_[0]) }
300 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
301=item cf::lock_wait $string 445=item cf::lock_wait $string
302 446
303Wait until the given lock is available. See cf::lock_acquire. 447Wait until the given lock is available. See cf::lock_acquire.
304 448
305=item my $lock = cf::lock_acquire $string 449=item my $lock = cf::lock_acquire $string
306 450
307Wait 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
308a 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,
309for example when the coroutine gets canceled), the lock is automatically 453for example when the coroutine gets canceled), the lock is automatically
310returned. 454returned.
311 455
312Locks 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
313deadlocked coro. 457deadlocked coro.
319 463
320Return 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.
321 465
322=cut 466=cut
323 467
324our %LOCK; 468our $LOCKS = new Coro::SemaphoreSet;
325our %LOCKER;#d#
326 469
327sub lock_wait($) { 470sub lock_wait($) {
328 my ($key) = @_; 471 $LOCKS->wait ($_[0]);
329
330 if ($LOCKER{$key} == $Coro::current) {#d#
331 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
332 return;#d#
333 }#d#
334
335 # wait for lock, if any
336 while ($LOCK{$key}) {
337 push @{ $LOCK{$key} }, $Coro::current;
338 Coro::schedule;
339 }
340} 472}
341 473
342sub lock_acquire($) { 474sub lock_acquire($) {
343 my ($key) = @_; 475 $LOCKS->guard ($_[0])
344
345 # wait, to be sure we are not locked
346 lock_wait $key;
347
348 $LOCK{$key} = [];
349 $LOCKER{$key} = $Coro::current;#d#
350
351 Coro::guard {
352 delete $LOCKER{$key};#d#
353 # wake up all waiters, to be on the safe side
354 $_->ready for @{ delete $LOCK{$key} };
355 }
356} 476}
357 477
358sub lock_active($) { 478sub lock_active($) {
359 my ($key) = @_; 479 $LOCKS->count ($_[0]) < 1
360
361 ! ! $LOCK{$key}
362} 480}
363 481
364sub freeze_mainloop { 482sub freeze_mainloop {
365 tick_inhibit_inc; 483 tick_inhibit_inc;
366 484
367 Coro::guard \&tick_inhibit_dec; 485 &Guard::guard (\&tick_inhibit_dec);
368} 486}
369 487
370=item cf::periodic $interval, $cb 488=item cf::periodic $interval, $cb
371 489
372Like 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
373get spread over timer. 491get spread over time.
374 492
375=cut 493=cut
376 494
377sub periodic($$) { 495sub periodic($$) {
378 my ($interval, $cb) = @_; 496 my ($interval, $cb) = @_;
382 EV::periodic $start, $interval, 0, $cb 500 EV::periodic $start, $interval, 0, $cb
383} 501}
384 502
385=item cf::get_slot $time[, $priority[, $name]] 503=item cf::get_slot $time[, $priority[, $name]]
386 504
387Allocate $time seconds of blocking CPU time at priority C<$priority>: 505Allocate $time seconds of blocking CPU time at priority C<$priority>
388This 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
389of 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.
390 512
391The 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
392used for statistical purposes and should identify the same time-class. 514used for statistical purposes and should identify the same time-class.
393 515
394Useful for short background jobs. 516Useful for short background jobs.
395 517
396=cut 518=cut
397 519
398our @SLOT_QUEUE; 520our @SLOT_QUEUE;
399our $SLOT_QUEUE; 521our $SLOT_QUEUE;
522our $SLOT_DECAY = 0.9;
400 523
401$SLOT_QUEUE->cancel if $SLOT_QUEUE; 524$SLOT_QUEUE->cancel if $SLOT_QUEUE;
402$SLOT_QUEUE = Coro::async { 525$SLOT_QUEUE = Coro::async {
403 $Coro::current->desc ("timeslot manager"); 526 $Coro::current->desc ("timeslot manager");
404 527
405 my $signal = new Coro::Signal; 528 my $signal = new Coro::Signal;
529 my $busy;
406 530
407 while () { 531 while () {
408 next_job: 532 next_job:
533
409 my $avail = cf::till_tick; 534 my $avail = cf::till_tick;
410 if ($avail > 0.01) { 535
411 for (0 .. $#SLOT_QUEUE) { 536 for (0 .. $#SLOT_QUEUE) {
412 if ($SLOT_QUEUE[$_][0] < $avail) { 537 if ($SLOT_QUEUE[$_][0] <= $avail) {
538 $busy = 0;
413 my $job = splice @SLOT_QUEUE, $_, 1, (); 539 my $job = splice @SLOT_QUEUE, $_, 1, ();
414 $job->[2]->send; 540 $job->[2]->send;
415 Coro::cede; 541 Coro::cede;
416 goto next_job; 542 goto next_job;
417 } 543 } else {
544 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
418 } 545 }
419 } 546 }
420 547
421 if (@SLOT_QUEUE) { 548 if (@SLOT_QUEUE) {
422 # 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
423 push @cf::WAIT_FOR_TICK, $signal; 550 push @cf::WAIT_FOR_TICK, $signal;
424 $signal->wait; 551 $signal->wait;
425 } else { 552 } else {
553 $busy = 0;
426 Coro::schedule; 554 Coro::schedule;
427 } 555 }
428 } 556 }
429}; 557};
430 558
431sub get_slot($;$$) { 559sub get_slot($;$$) {
432 return if tick_inhibit || $Coro::current == $Coro::main; 560 return if tick_inhibit || $Coro::current == $Coro::main;
433 561
434 my ($time, $pri, $name) = @_; 562 my ($time, $pri, $name) = @_;
435 563
436 $time = $TICK * .6 if $time > $TICK * .6; 564 $time = clamp $time, 0.01, $TICK * .6;
565
437 my $sig = new Coro::Signal; 566 my $sig = new Coro::Signal;
438 567
439 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 568 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
440 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 569 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
441 $SLOT_QUEUE->ready; 570 $SLOT_QUEUE->ready;
467=cut 596=cut
468 597
469sub sync_job(&) { 598sub sync_job(&) {
470 my ($job) = @_; 599 my ($job) = @_;
471 600
472 if ($Coro::current == $Coro::main) { 601 if (in_main) {
473 my $time = EV::time; 602 my $time = AE::time;
474 603
475 # this is the main coro, too bad, we have to block 604 # this is the main coro, too bad, we have to block
476 # till the operation succeeds, freezing the server :/ 605 # till the operation succeeds, freezing the server :/
477 606
478 LOG llevError, Carp::longmess "sync job";#d# 607 #LOG llevError, Carp::longmess "sync job";#d#
479 608
480 my $freeze_guard = freeze_mainloop; 609 my $freeze_guard = freeze_mainloop;
481 610
482 my $busy = 1; 611 my $busy = 1;
483 my @res; 612 my @res;
484 613
485 (async { 614 (async {
486 $Coro::current->desc ("sync job coro"); 615 $Coro::current->desc ("sync job coro");
487 @res = eval { $job->() }; 616 @res = eval { $job->() };
488 warn $@ if $@; 617 error $@ if $@;
489 undef $busy; 618 undef $busy;
490 })->prio (Coro::PRIO_MAX); 619 })->prio (Coro::PRIO_MAX);
491 620
492 while ($busy) { 621 while ($busy) {
493 if (Coro::nready) { 622 if (Coro::nready) {
495 } else { 624 } else {
496 EV::loop EV::LOOP_ONESHOT; 625 EV::loop EV::LOOP_ONESHOT;
497 } 626 }
498 } 627 }
499 628
500 my $time = EV::time - $time; 629 my $time = AE::time - $time;
501 630
502 $TICK_START += $time; # do not account sync jobs to server load 631 $TICK_START += $time; # do not account sync jobs to server load
503 632
504 wantarray ? @res : $res[0] 633 wantarray ? @res : $res[0]
505 } else { 634 } else {
527 $EXT_CORO{$coro+0} = $coro; 656 $EXT_CORO{$coro+0} = $coro;
528 657
529 $coro 658 $coro
530} 659}
531 660
532=item fork_call { }, $args 661=item fork_call { }, @args
533 662
534Executes the given code block with the given arguments in a seperate 663Executes the given code block with the given arguments in a seperate
535process, returning the results. Everything must be serialisable with 664process, returning the results. Everything must be serialisable with
536Coro::Storable. May, of course, block. Note that the executed sub may 665Coro::Storable. May, of course, block. Note that the executed sub may
537never block itself or use any form of event handling. 666never block itself or use any form of event handling.
538 667
539=cut 668=cut
540 669
670sub post_fork {
671 reset_signals;
672}
673
541sub fork_call(&@) { 674sub fork_call(&@) {
542 my ($cb, @args) = @_; 675 my ($cb, @args) = @_;
543 676
544 # 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,
545 # otherwise perl prematurely frees the stuff :/ 678 # otherwise perl prematurely frees the stuff :/
546 # TODO: investigate and fix (likely this will be rather laborious) 679 # TODO: investigate and fix (likely this will be rather laborious)
547 680
548 my @res = Coro::Util::fork_eval { 681 my @res = Coro::Util::fork_eval {
549 reset_signals; 682 cf::post_fork;
550 &$cb 683 &$cb
551 }, @args; 684 } @args;
552 685
553 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 )
554} 698}
555 699
556=item $coin = coin_from_name $name 700=item $coin = coin_from_name $name
557 701
558=cut 702=cut
595within each server. 739within each server.
596 740
597=cut 741=cut
598 742
599sub db_table($) { 743sub db_table($) {
744 cf::error "db_get called from main context"
745 if $Coro::current == $Coro::main;
746
600 my ($name) = @_; 747 my ($name) = @_;
601 my $db = BDB::db_create $DB_ENV; 748 my $db = BDB::db_create $DB_ENV;
602 749
603 eval { 750 eval {
604 $db->set_flags (BDB::CHKSUM); 751 $db->set_flags (BDB::CHKSUM);
614} 761}
615 762
616our $DB; 763our $DB;
617 764
618sub db_init { 765sub db_init {
619 cf::sync_job {
620 $DB ||= db_table "db"; 766 $DB ||= db_table "db";
621 };
622} 767}
623 768
624sub db_get($$) { 769sub db_get($$) {
625 my $key = "$_[0]/$_[1]"; 770 my $key = "$_[0]/$_[1]";
626 771
627 cf::sync_job { 772 cf::error "db_get called from main context"
773 if $Coro::current == $Coro::main;
774
628 BDB::db_get $DB, undef, $key, my $data; 775 BDB::db_get $DB, undef, $key, my $data;
629 776
630 $! ? () 777 $! ? ()
631 : $data 778 : $data
632 }
633} 779}
634 780
635sub db_put($$$) { 781sub db_put($$$) {
636 BDB::dbreq_pri 4; 782 BDB::dbreq_pri 4;
637 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 783 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
665 811
666 my @data; 812 my @data;
667 my $md5; 813 my $md5;
668 814
669 for (0 .. $#$src) { 815 for (0 .. $#$src) {
670 0 <= aio_load $src->[$_], $data[$_] 816 $data[$_] = load_file $src->[$_];
671 or Carp::croak "$src->[$_]: $!";
672 } 817 }
673 818
674 # if processing is expensive, check 819 # if processing is expensive, check
675 # checksum first 820 # checksum first
676 if (1) { 821 if (1) {
693 838
694 my $t1 = Time::HiRes::time; 839 my $t1 = Time::HiRes::time;
695 my $data = $process->(\@data); 840 my $data = $process->(\@data);
696 my $t2 = Time::HiRes::time; 841 my $t2 = Time::HiRes::time;
697 842
698 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 843 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
699 844
700 db_put cache => "$id/data", $data; 845 db_put cache => "$id/data", $data;
701 db_put cache => "$id/md5" , $md5; 846 db_put cache => "$id/md5" , $md5;
702 db_put cache => "$id/meta", $meta; 847 db_put cache => "$id/meta", $meta;
703 848
713 858
714=cut 859=cut
715 860
716sub datalog($@) { 861sub datalog($@) {
717 my ($type, %kv) = @_; 862 my ($type, %kv) = @_;
718 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 863 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
719} 864}
720 865
721=back 866=back
722 867
723=cut 868=cut
724 869
725############################################################################# 870#############################################################################
726 871
727=head2 ATTACHABLE OBJECTS 872=head2 ATTACHABLE OBJECTS
728 873
729Many 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
730attach callbacks/event handlers (a collection of which is called an "attachment") 875attach callbacks/event handlers (a collection of which is called an "attachment")
731to it. All such attachable objects support the following methods. 876to it. All such attachable objects support the following methods.
732 877
733In 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>
734C<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
784=item cf::CLASS::attachment $name, ... 929=item cf::CLASS::attachment $name, ...
785 930
786Register an attachment by C<$name> through which attachable objects of the 931Register an attachment by C<$name> through which attachable objects of the
787given CLASS can refer to this attachment. 932given CLASS can refer to this attachment.
788 933
789Some classes such as crossfire maps and objects can specify attachments 934Some classes such as deliantra maps and objects can specify attachments
790that 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.
791 936
792These calls expect any number of the following handler/hook descriptions: 937These calls expect any number of the following handler/hook descriptions:
793 938
794=over 4 939=over 4
918 1063
919 } elsif (exists $cb_id{$type}) { 1064 } elsif (exists $cb_id{$type}) {
920 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1065 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
921 1066
922 } elsif (ref $type) { 1067 } elsif (ref $type) {
923 warn "attaching objects not supported, ignoring.\n"; 1068 error "attaching objects not supported, ignoring.\n";
924 1069
925 } else { 1070 } else {
926 shift @arg; 1071 shift @arg;
927 warn "attach argument '$type' not supported, ignoring.\n"; 1072 error "attach argument '$type' not supported, ignoring.\n";
928 } 1073 }
929 } 1074 }
930} 1075}
931 1076
932sub _object_attach { 1077sub _object_attach {
942 _attach $registry, $klass, @attach; 1087 _attach $registry, $klass, @attach;
943 } 1088 }
944 1089
945 $obj->{$name} = \%arg; 1090 $obj->{$name} = \%arg;
946 } else { 1091 } else {
947 warn "object uses attachment '$name' which is not available, postponing.\n"; 1092 info "object uses attachment '$name' which is not available, postponing.\n";
948 } 1093 }
949 1094
950 $obj->{_attachment}{$name} = undef; 1095 $obj->{_attachment}{$name} = undef;
951} 1096}
952 1097
1011 1156
1012 for (@$callbacks) { 1157 for (@$callbacks) {
1013 eval { &{$_->[1]} }; 1158 eval { &{$_->[1]} };
1014 1159
1015 if ($@) { 1160 if ($@) {
1016 warn "$@";
1017 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1161 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1018 override; 1162 override;
1019 } 1163 }
1020 1164
1021 return 1 if $override; 1165 return 1 if $override;
1022 } 1166 }
1085 1229
1086sub reattach { 1230sub reattach {
1087 # basically do the same as instantiate, without calling instantiate 1231 # basically do the same as instantiate, without calling instantiate
1088 my ($obj) = @_; 1232 my ($obj) = @_;
1089 1233
1234 # no longer needed after getting rid of delete_package?
1090 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1235 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1091 1236
1092 my $registry = $obj->registry; 1237 my $registry = $obj->registry;
1093 1238
1094 @$registry = (); 1239 @$registry = ();
1095 1240
1100 for (@$attach) { 1245 for (@$attach) {
1101 my ($klass, @attach) = @$_; 1246 my ($klass, @attach) = @$_;
1102 _attach $registry, $klass, @attach; 1247 _attach $registry, $klass, @attach;
1103 } 1248 }
1104 } else { 1249 } else {
1105 warn "object uses attachment '$name' that is not available, postponing.\n"; 1250 info "object uses attachment '$name' that is not available, postponing.\n";
1106 } 1251 }
1107 } 1252 }
1108} 1253}
1109 1254
1110cf::attachable->attach ( 1255cf::attachable->attach (
1137 my ($filename, $rdata, $objs) = @_; 1282 my ($filename, $rdata, $objs) = @_;
1138 1283
1139 sync_job { 1284 sync_job {
1140 if (length $$rdata) { 1285 if (length $$rdata) {
1141 utf8::decode (my $decname = $filename); 1286 utf8::decode (my $decname = $filename);
1142 warn sprintf "saving %s (%d,%d)\n", 1287 trace sprintf "saving %s (%d,%d)\n",
1143 $decname, length $$rdata, scalar @$objs; 1288 $decname, length $$rdata, scalar @$objs
1289 if $VERBOSE_IO;
1144 1290
1145 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1291 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1146 aio_chmod $fh, SAVE_MODE; 1292 aio_chmod $fh, SAVE_MODE;
1147 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1293 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1148 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 }
1149 aio_close $fh; 1298 aio_close $fh;
1150 1299
1151 if (@$objs) { 1300 if (@$objs) {
1152 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) {
1153 aio_chmod $fh, SAVE_MODE; 1302 aio_chmod $fh, SAVE_MODE;
1154 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1303 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1155 aio_write $fh, 0, (length $data), $data, 0; 1304 aio_write $fh, 0, (length $data), $data, 0;
1156 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 }
1157 aio_close $fh; 1309 aio_close $fh;
1158 aio_rename "$filename.pst~", "$filename.pst"; 1310 aio_rename "$filename.pst~", "$filename.pst";
1159 } 1311 }
1160 } else { 1312 } else {
1161 aio_unlink "$filename.pst"; 1313 aio_unlink "$filename.pst";
1162 } 1314 }
1163 1315
1164 aio_rename "$filename~", $filename; 1316 aio_rename "$filename~", $filename;
1317
1318 $filename =~ s%/[^/]+$%%;
1319 aio_pathsync $filename if $cf::USE_FSYNC;
1165 } else { 1320 } else {
1166 warn "FATAL: $filename~: $!\n"; 1321 error "unable to save objects: $filename~: $!\n";
1167 } 1322 }
1168 } else { 1323 } else {
1169 aio_unlink $filename; 1324 aio_unlink $filename;
1170 aio_unlink "$filename.pst"; 1325 aio_unlink "$filename.pst";
1171 } 1326 }
1195 my $st = eval { Coro::Storable::thaw $av }; 1350 my $st = eval { Coro::Storable::thaw $av };
1196 $av = $st->{objs}; 1351 $av = $st->{objs};
1197 } 1352 }
1198 1353
1199 utf8::decode (my $decname = $filename); 1354 utf8::decode (my $decname = $filename);
1200 warn sprintf "loading %s (%d,%d)\n", 1355 trace sprintf "loading %s (%d,%d)\n",
1201 $decname, length $data, scalar @{$av || []}; 1356 $decname, length $data, scalar @{$av || []}
1357 if $VERBOSE_IO;
1202 1358
1203 ($data, $av) 1359 ($data, $av)
1204} 1360}
1205 1361
1206=head2 COMMAND CALLBACKS 1362=head2 COMMAND CALLBACKS
1262 my ($name, $cb) = @_; 1418 my ($name, $cb) = @_;
1263 1419
1264 $EXTICMD{$name} = $cb; 1420 $EXTICMD{$name} = $cb;
1265} 1421}
1266 1422
1423use File::Glob ();
1424
1267cf::player->attach ( 1425cf::player->attach (
1268 on_command => sub { 1426 on_unknown_command => sub {
1269 my ($pl, $name, $params) = @_; 1427 my ($pl, $name, $params) = @_;
1270 1428
1271 my $cb = $COMMAND{$name} 1429 my $cb = $COMMAND{$name}
1272 or return; 1430 or return;
1273 1431
1296 1454
1297 $pl->ext_reply ($reply, @reply) 1455 $pl->ext_reply ($reply, @reply)
1298 if $reply; 1456 if $reply;
1299 1457
1300 } else { 1458 } else {
1301 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1459 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1302 } 1460 }
1303 1461
1304 cf::override; 1462 cf::override;
1305 }, 1463 },
1306); 1464);
1307 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
1308sub load_extensions { 1479sub load_extensions {
1480 info "loading extensions...";
1481
1309 cf::sync_job { 1482 cf::sync_job {
1310 my %todo; 1483 my %todo;
1311 1484
1312 for my $path (<$LIBDIR/*.ext>) { 1485 for my $path (<$LIBDIR/*.ext>) {
1313 next unless -r $path; 1486 next unless -r $path;
1331 1504
1332 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1505 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1333 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1506 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1334 1507
1335 $ext{source} = 1508 $ext{source} =
1336 "package $pkg; use strict; use utf8;\n" 1509 "package $pkg; use common::sense;\n"
1337 . "#line 1 \"$path\"\n{\n" 1510 . "#line 1 \"$path\"\n{\n"
1338 . $source 1511 . $source
1339 . "\n};\n1"; 1512 . "\n};\n1";
1340 1513
1341 $todo{$base} = \%ext; 1514 $todo{$base} = \%ext;
1342 } 1515 }
1343 1516
1517 my $pass = 0;
1344 my %done; 1518 my %done;
1345 while (%todo) { 1519 while (%todo) {
1346 my $progress; 1520 my $progress;
1347 1521
1522 ++$pass;
1523
1524 ext:
1348 while (my ($k, $v) = each %todo) { 1525 while (my ($k, $v) = each %todo) {
1349 for (split /,\s*/, $v->{meta}{depends}) { 1526 for (split /,\s*/, $v->{meta}{depends}) {
1350 goto skip 1527 next ext
1351 unless exists $done{$_}; 1528 unless exists $done{$_};
1352 } 1529 }
1353 1530
1354 warn "... loading '$k' into '$v->{pkg}'\n"; 1531 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1355 1532
1356 unless (eval $v->{source}) { 1533 my $active = eval $v->{source};
1534
1535 if (length $@) {
1357 my $msg = $@ ? "$v->{path}: $@\n" 1536 error "$v->{path}: $@\n";
1358 : "$v->{base}: extension inactive.\n";
1359 1537
1360 if (exists $v->{meta}{mandatory}) {
1361 warn $msg;
1362 cf::cleanup "mandatory extension failed to load, exiting."; 1538 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1363 } 1539 if exists $v->{meta}{mandatory};
1364 1540
1365 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;
1366 } 1550 }
1367
1368 $done{$k} = delete $todo{$k};
1369 push @EXTS, $v->{pkg};
1370 $progress = 1;
1371 } 1551 }
1372 1552
1373 skip: 1553 unless ($progress) {
1374 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1554 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1375 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 }
1376 } 1561 }
1377 }; 1562 };
1378} 1563}
1379 1564
1380############################################################################# 1565#############################################################################
1381 1566
1382=back 1567=back
1383 1568
1384=head2 CORE EXTENSIONS 1569=head2 CORE EXTENSIONS
1385 1570
1386Functions and methods that extend core crossfire objects. 1571Functions and methods that extend core deliantra objects.
1387 1572
1388=cut 1573=cut
1389 1574
1390package cf::player; 1575package cf::player;
1391 1576
1434 1619
1435sub exists($) { 1620sub exists($) {
1436 my ($login) = @_; 1621 my ($login) = @_;
1437 1622
1438 $cf::PLAYER{$login} 1623 $cf::PLAYER{$login}
1439 or cf::sync_job { !aio_stat path $login } 1624 or !aio_stat path $login
1440} 1625}
1441 1626
1442sub find($) { 1627sub find($) {
1443 return $cf::PLAYER{$_[0]} || do { 1628 return $cf::PLAYER{$_[0]} || do {
1444 my $login = $_[0]; 1629 my $login = $_[0];
1464 $cf::PLAYER{$login} = $pl 1649 $cf::PLAYER{$login} = $pl
1465 } 1650 }
1466 } 1651 }
1467} 1652}
1468 1653
1654cf::player->attach (
1655 on_load => sub {
1656 my ($pl, $path) = @_;
1657
1658 # restore slots saved in save, below
1659 my $slots = delete $pl->{_slots};
1660
1661 $pl->ob->current_weapon ($slots->[0]);
1662 $pl->combat_ob ($slots->[1]);
1663 $pl->ranged_ob ($slots->[2]);
1664 },
1665);
1666
1469sub save($) { 1667sub save($) {
1470 my ($pl) = @_; 1668 my ($pl) = @_;
1471 1669
1472 return if $pl->{deny_save}; 1670 return if $pl->{deny_save};
1473 1671
1478 1676
1479 aio_mkdir playerdir $pl, 0770; 1677 aio_mkdir playerdir $pl, 0770;
1480 $pl->{last_save} = $cf::RUNTIME; 1678 $pl->{last_save} = $cf::RUNTIME;
1481 1679
1482 cf::get_slot 0.01; 1680 cf::get_slot 0.01;
1681
1682 # save slots, to be restored later
1683 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1483 1684
1484 $pl->save_pl ($path); 1685 $pl->save_pl ($path);
1485 cf::cede_to_tick; 1686 cf::cede_to_tick;
1486} 1687}
1487 1688
1519 my ($pl) = @_; 1720 my ($pl) = @_;
1520 1721
1521 my $name = $pl->ob->name; 1722 my $name = $pl->ob->name;
1522 1723
1523 $pl->{deny_save} = 1; 1724 $pl->{deny_save} = 1;
1524 $pl->password ("*"); # this should lock out the player until we nuked the dir 1725 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1525 1726
1526 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1727 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1527 $pl->deactivate; 1728 $pl->deactivate;
1729
1730 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1528 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1731 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1732 ext::highscore::check ($pl->ob);
1733
1529 $pl->ns->destroy if $pl->ns; 1734 $pl->ns->destroy if $pl->ns;
1530 1735
1531 my $path = playerdir $pl; 1736 my $path = playerdir $pl;
1532 my $temp = "$path~$cf::RUNTIME~deleting~"; 1737 my $temp = "$path~$cf::RUNTIME~deleting~";
1533 aio_rename $path, $temp; 1738 aio_rename $path, $temp;
1587 \@logins 1792 \@logins
1588} 1793}
1589 1794
1590=item $player->maps 1795=item $player->maps
1591 1796
1797=item cf::player::maps $login
1798
1592Returns an arrayref of map paths that are private for this 1799Returns an arrayref of map paths that are private for this
1593player. May block. 1800player. May block.
1594 1801
1595=cut 1802=cut
1596 1803
1613 } 1820 }
1614 1821
1615 \@paths 1822 \@paths
1616} 1823}
1617 1824
1618=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1825=item $protocol_xml = $player->expand_cfpod ($cfpod)
1619 1826
1620Expand crossfire pod fragments into protocol xml. 1827Expand deliantra pod fragments into protocol xml.
1621
1622=cut
1623
1624use re 'eval';
1625
1626my $group;
1627my $interior; $interior = qr{
1628 # match a pod interior sequence sans C<< >>
1629 (?:
1630 \ (.*?)\ (?{ $group = $^N })
1631 | < (??{$interior}) >
1632 )
1633}x;
1634
1635sub expand_cfpod {
1636 my ($self, $pod) = @_;
1637
1638 my $xml;
1639
1640 while () {
1641 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1642 $group = $1;
1643
1644 $group =~ s/&/&amp;/g;
1645 $group =~ s/</&lt;/g;
1646
1647 $xml .= $group;
1648 } elsif ($pod =~ m%\G
1649 ([BCGHITU])
1650 <
1651 (?:
1652 ([^<>]*) (?{ $group = $^N })
1653 | < $interior >
1654 )
1655 >
1656 %gcsx
1657 ) {
1658 my ($code, $data) = ($1, $group);
1659
1660 if ($code eq "B") {
1661 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1662 } elsif ($code eq "I") {
1663 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1664 } elsif ($code eq "U") {
1665 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1666 } elsif ($code eq "C") {
1667 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1668 } elsif ($code eq "T") {
1669 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1670 } elsif ($code eq "G") {
1671 my ($male, $female) = split /\|/, $data;
1672 $data = $self->gender ? $female : $male;
1673 $xml .= expand_cfpod ($self, $data);
1674 } elsif ($code eq "H") {
1675 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1676 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1677 "")
1678 [$self->{hintmode}];
1679 } else {
1680 $xml .= "error processing '$code($data)' directive";
1681 }
1682 } else {
1683 if ($pod =~ /\G(.+)/) {
1684 warn "parse error while expanding $pod (at $1)";
1685 }
1686 last;
1687 }
1688 }
1689
1690 for ($xml) {
1691 # create single paragraphs (very hackish)
1692 s/(?<=\S)\n(?=\w)/ /g;
1693
1694 # compress some whitespace
1695 s/\s+\n/\n/g; # ws line-ends
1696 s/\n\n+/\n/g; # double lines
1697 s/^\n+//; # beginning lines
1698 s/\n+$//; # ending lines
1699 }
1700
1701 $xml
1702}
1703
1704no re 'eval';
1705
1706sub hintmode {
1707 $_[0]{hintmode} = $_[1] if @_ > 1;
1708 $_[0]{hintmode}
1709}
1710 1828
1711=item $player->ext_reply ($msgid, @msg) 1829=item $player->ext_reply ($msgid, @msg)
1712 1830
1713Sends an ext reply to the player. 1831Sends an ext reply to the player.
1714 1832
1746 1864
1747=cut 1865=cut
1748 1866
1749sub find_by_path($) { 1867sub find_by_path($) {
1750 my ($path) = @_; 1868 my ($path) = @_;
1869
1870 $path =~ s/^~[^\/]*//; # skip ~login
1751 1871
1752 my ($match, $specificity); 1872 my ($match, $specificity);
1753 1873
1754 for my $region (list) { 1874 for my $region (list) {
1755 if ($region->{match} && $path =~ $region->{match}) { 1875 if ($region->{match} && $path =~ $region->{match}) {
1784sub generate_random_map { 1904sub generate_random_map {
1785 my ($self, $rmp) = @_; 1905 my ($self, $rmp) = @_;
1786 1906
1787 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1907 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1788 1908
1789 # mit "rum" bekleckern, nicht
1790 $self->_create_random_map ( 1909 $self->_create_random_map ($rmp);
1791 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1792 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1793 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1794 $rmp->{exit_on_final_map},
1795 $rmp->{xsize}, $rmp->{ysize},
1796 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1797 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1798 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1799 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1800 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1801 (cf::region::find $rmp->{region}), $rmp->{custom}
1802 )
1803} 1910}
1804 1911
1805=item cf::map->register ($regex, $prio) 1912=item cf::map->register ($regex, $prio)
1806 1913
1807Register a handler for the map path matching the given regex at the 1914Register a handler for the map path matching the given regex at the
1812 1919
1813sub register { 1920sub register {
1814 my (undef, $regex, $prio) = @_; 1921 my (undef, $regex, $prio) = @_;
1815 my $pkg = caller; 1922 my $pkg = caller;
1816 1923
1817 no strict;
1818 push @{"$pkg\::ISA"}, __PACKAGE__; 1924 push @{"$pkg\::ISA"}, __PACKAGE__;
1819 1925
1820 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1926 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1821} 1927}
1822 1928
1823# also paths starting with '/' 1929# also paths starting with '/'
1824$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1930$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1825 1931
1826sub thawer_merge { 1932sub thawer_merge {
1827 my ($self, $merge) = @_; 1933 my ($self, $merge) = @_;
1828 1934
1829 # we have to keep some variables in memory intact 1935 # we have to keep some variables in memory intact
1834} 1940}
1835 1941
1836sub normalise { 1942sub normalise {
1837 my ($path, $base) = @_; 1943 my ($path, $base) = @_;
1838 1944
1839 $path = "$path"; # make sure its a string 1945 $path = "$path"; # make sure it's a string
1840 1946
1841 $path =~ s/\.map$//; 1947 $path =~ s/\.map$//;
1842 1948
1843 # map plan: 1949 # map plan:
1844 # 1950 #
1859 $base =~ s{[^/]+/?$}{}; 1965 $base =~ s{[^/]+/?$}{};
1860 $path = "$base/$path"; 1966 $path = "$base/$path";
1861 } 1967 }
1862 1968
1863 for ($path) { 1969 for ($path) {
1864 redo if s{//}{/};
1865 redo if s{/\.?/}{/}; 1970 redo if s{/\.?/}{/};
1866 redo if s{/[^/]+/\.\./}{/}; 1971 redo if s{/[^/]+/\.\./}{/};
1867 } 1972 }
1868 1973
1869 $path 1974 $path
1883 $self->init; # pass $1 etc. 1988 $self->init; # pass $1 etc.
1884 return $self; 1989 return $self;
1885 } 1990 }
1886 } 1991 }
1887 1992
1888 Carp::cluck "unable to resolve path '$path' (base '$base')."; 1993 Carp::cluck "unable to resolve path '$path' (base '$base')";
1889 () 1994 ()
1890} 1995}
1891 1996
1892sub init { 1997sub init {
1893 my ($self) = @_; 1998 my ($self) = @_;
1925sub uniq_path { 2030sub uniq_path {
1926 my ($self) = @_; 2031 my ($self) = @_;
1927 2032
1928 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 2033 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1929 "$UNIQUEDIR/$path" 2034 "$UNIQUEDIR/$path"
1930}
1931
1932# and all this just because we cannot iterate over
1933# all maps in C++...
1934sub change_all_map_light {
1935 my ($change) = @_;
1936
1937 $_->change_map_light ($change)
1938 for grep $_->outdoor, values %cf::MAP;
1939} 2035}
1940 2036
1941sub decay_objects { 2037sub decay_objects {
1942 my ($self) = @_; 2038 my ($self) = @_;
1943 2039
2025 2121
2026sub find; 2122sub find;
2027sub find { 2123sub find {
2028 my ($path, $origin) = @_; 2124 my ($path, $origin) = @_;
2029 2125
2126 cf::cede_to_tick;
2127
2030 $path = normalise $path, $origin && $origin->path; 2128 $path = normalise $path, $origin && $origin->path;
2031 2129
2032 cf::lock_wait "map_data:$path";#d#remove 2130 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2033 cf::lock_wait "map_find:$path"; 2131 my $guard2 = cf::lock_acquire "map_find:$path";
2034 2132
2035 $cf::MAP{$path} || do { 2133 $cf::MAP{$path} || do {
2036 my $guard1 = cf::lock_acquire "map_find:$path";
2037 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2038
2039 my $map = new_from_path cf::map $path 2134 my $map = new_from_path cf::map $path
2040 or return; 2135 or return;
2041 2136
2042 $map->{last_save} = $cf::RUNTIME; 2137 $map->{last_save} = $cf::RUNTIME;
2043 2138
2045 or return; 2140 or return;
2046 2141
2047 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2142 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2048 # doing this can freeze the server in a sync job, obviously 2143 # doing this can freeze the server in a sync job, obviously
2049 #$cf::WAIT_FOR_TICK->wait; 2144 #$cf::WAIT_FOR_TICK->wait;
2145 undef $guard2;
2050 undef $guard1; 2146 undef $guard1;
2051 undef $guard2;
2052 $map->reset; 2147 $map->reset;
2053 return find $path; 2148 return find $path;
2054 } 2149 }
2055 2150
2056 $cf::MAP{$path} = $map 2151 $cf::MAP{$path} = $map
2057 } 2152 }
2058} 2153}
2059 2154
2060sub pre_load { } 2155sub pre_load { }
2061sub post_load { } 2156#sub post_load { } # XS
2062 2157
2063sub load { 2158sub load {
2064 my ($self) = @_; 2159 my ($self) = @_;
2065 2160
2066 local $self->{deny_reset} = 1; # loading can take a long time 2161 local $self->{deny_reset} = 1; # loading can take a long time
2083 my $f = new_from_file cf::object::thawer $self->{load_path}; 2178 my $f = new_from_file cf::object::thawer $self->{load_path};
2084 $f->skip_block; 2179 $f->skip_block;
2085 $self->_load_objects ($f) 2180 $self->_load_objects ($f)
2086 or return; 2181 or return;
2087 2182
2088 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2183 $self->post_load_original
2089 if delete $self->{load_original}; 2184 if delete $self->{load_original};
2090 2185
2091 if (my $uniq = $self->uniq_path) { 2186 if (my $uniq = $self->uniq_path) {
2092 utf8::encode $uniq; 2187 utf8::encode $uniq;
2093 unless (aio_stat $uniq) { 2188 unless (aio_stat $uniq) {
2111 unless ($self->{deny_activate}) { 2206 unless ($self->{deny_activate}) {
2112 $self->decay_objects; 2207 $self->decay_objects;
2113 $self->fix_auto_apply; 2208 $self->fix_auto_apply;
2114 $self->update_buttons; 2209 $self->update_buttons;
2115 cf::cede_to_tick; 2210 cf::cede_to_tick;
2116 $self->set_darkness_map;
2117 cf::cede_to_tick;
2118 $self->activate; 2211 $self->activate;
2119 } 2212 }
2120 2213
2121 $self->{last_save} = $cf::RUNTIME; 2214 $self->{last_save} = $cf::RUNTIME;
2122 $self->last_access ($cf::RUNTIME); 2215 $self->last_access ($cf::RUNTIME);
2123 2216
2124 $self->in_memory (cf::MAP_ACTIVE); 2217 $self->in_memory (cf::MAP_ACTIVE);
2125 } 2218 }
2126 2219
2127 $self->post_load; 2220 $self->post_load;
2128}
2129 2221
2222 1
2223}
2224
2225# customize the map for a given player, i.e.
2226# return the _real_ map. used by e.g. per-player
2227# maps to change the path to ~playername/mappath
2130sub customise_for { 2228sub customise_for {
2131 my ($self, $ob) = @_; 2229 my ($self, $ob) = @_;
2132 2230
2133 return find "~" . $ob->name . "/" . $self->{path} 2231 return find "~" . $ob->name . "/" . $self->{path}
2134 if $self->per_player; 2232 if $self->per_player;
2150 or next; 2248 or next;
2151 $neigh = find $neigh, $map 2249 $neigh = find $neigh, $map
2152 or next; 2250 or next;
2153 $neigh->load; 2251 $neigh->load;
2154 2252
2253 # now find the diagonal neighbours
2155 push @neigh, 2254 push @neigh,
2156 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2255 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2157 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2256 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2158 } 2257 }
2159 2258
2166} 2265}
2167 2266
2168sub find_sync { 2267sub find_sync {
2169 my ($path, $origin) = @_; 2268 my ($path, $origin) = @_;
2170 2269
2171 cf::sync_job { find $path, $origin } 2270 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2271 if $Coro::current == $Coro::main;
2272
2273 find $path, $origin
2172} 2274}
2173 2275
2174sub do_load_sync { 2276sub do_load_sync {
2175 my ($map) = @_; 2277 my ($map) = @_;
2176 2278
2177 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2279 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2178 if $Coro::current == $Coro::main; 2280 if $Coro::current == $Coro::main;
2179 2281
2180 cf::sync_job { $map->load }; 2282 $map->load;
2181} 2283}
2182 2284
2183our %MAP_PREFETCH; 2285our %MAP_PREFETCH;
2184our $MAP_PREFETCHER = undef; 2286our $MAP_PREFETCHER = undef;
2185 2287
2211 $MAP_PREFETCHER->prio (6); 2313 $MAP_PREFETCHER->prio (6);
2212 2314
2213 () 2315 ()
2214} 2316}
2215 2317
2318# common code, used by both ->save and ->swapout
2216sub save { 2319sub _save {
2217 my ($self) = @_; 2320 my ($self) = @_;
2218
2219 my $lock = cf::lock_acquire "map_data:$self->{path}";
2220 2321
2221 $self->{last_save} = $cf::RUNTIME; 2322 $self->{last_save} = $cf::RUNTIME;
2222 2323
2223 return unless $self->dirty; 2324 return unless $self->dirty;
2224 2325
2244 } else { 2345 } else {
2245 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2346 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2246 } 2347 }
2247} 2348}
2248 2349
2350sub save {
2351 my ($self) = @_;
2352
2353 my $lock = cf::lock_acquire "map_data:$self->{path}";
2354
2355 $self->_save;
2356}
2357
2249sub swap_out { 2358sub swap_out {
2250 my ($self) = @_; 2359 my ($self) = @_;
2251 2360
2252 # save first because save cedes
2253 $self->save;
2254
2255 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2361 my $lock = cf::lock_acquire "map_data:$self->{path}";
2256 2362
2257 return if $self->players;
2258 return if $self->in_memory != cf::MAP_ACTIVE; 2363 return if $self->in_memory != cf::MAP_ACTIVE;
2259 return if $self->{deny_save}; 2364 return if $self->{deny_save};
2365 return if $self->players;
2260 2366
2367 # first deactivate the map and "unlink" it from the core
2368 $self->deactivate;
2369 $_->clear_links_to ($self) for values %cf::MAP;
2261 $self->in_memory (cf::MAP_SWAPPED); 2370 $self->in_memory (cf::MAP_SWAPPED);
2371
2372 # then atomically save
2373 $self->_save;
2374
2375 # then free the map
2376 $self->clear;
2377}
2378
2379sub reset_at {
2380 my ($self) = @_;
2381
2382 # TODO: safety, remove and allow resettable per-player maps
2383 return 1e99 if $self->{deny_reset};
2384
2385 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2386 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2387
2388 $time + $to
2389}
2390
2391sub should_reset {
2392 my ($self) = @_;
2393
2394 $self->reset_at <= $cf::RUNTIME
2395}
2396
2397sub reset {
2398 my ($self) = @_;
2399
2400 my $lock = cf::lock_acquire "map_data:$self->{path}";
2401
2402 return if $self->players;
2403
2404 cf::trace "resetting map ", $self->path, "\n";
2405
2406 $self->in_memory (cf::MAP_SWAPPED);
2407
2408 # need to save uniques path
2409 unless ($self->{deny_save}) {
2410 my $uniq = $self->uniq_path; utf8::encode $uniq;
2411
2412 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2413 if $uniq;
2414 }
2415
2416 delete $cf::MAP{$self->path};
2262 2417
2263 $self->deactivate; 2418 $self->deactivate;
2264 $_->clear_links_to ($self) for values %cf::MAP; 2419 $_->clear_links_to ($self) for values %cf::MAP;
2265 $self->clear; 2420 $self->clear;
2266}
2267
2268sub reset_at {
2269 my ($self) = @_;
2270
2271 # TODO: safety, remove and allow resettable per-player maps
2272 return 1e99 if $self->{deny_reset};
2273
2274 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2275 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2276
2277 $time + $to
2278}
2279
2280sub should_reset {
2281 my ($self) = @_;
2282
2283 $self->reset_at <= $cf::RUNTIME
2284}
2285
2286sub reset {
2287 my ($self) = @_;
2288
2289 my $lock = cf::lock_acquire "map_data:$self->{path}";
2290
2291 return if $self->players;
2292
2293 warn "resetting map ", $self->path;
2294
2295 $self->in_memory (cf::MAP_SWAPPED);
2296
2297 # need to save uniques path
2298 unless ($self->{deny_save}) {
2299 my $uniq = $self->uniq_path; utf8::encode $uniq;
2300
2301 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2302 if $uniq;
2303 }
2304
2305 delete $cf::MAP{$self->path};
2306
2307 $self->deactivate;
2308 $_->clear_links_to ($self) for values %cf::MAP;
2309 $self->clear;
2310 2421
2311 $self->unlink_save; 2422 $self->unlink_save;
2312 $self->destroy; 2423 $self->destroy;
2313} 2424}
2314 2425
2322 2433
2323 delete $cf::MAP{$self->path}; 2434 delete $cf::MAP{$self->path};
2324 2435
2325 $self->unlink_save; 2436 $self->unlink_save;
2326 2437
2327 bless $self, "cf::map"; 2438 bless $self, "cf::map::wrap";
2328 delete $self->{deny_reset}; 2439 delete $self->{deny_reset};
2329 $self->{deny_save} = 1; 2440 $self->{deny_save} = 1;
2330 $self->reset_timeout (1); 2441 $self->reset_timeout (1);
2331 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2442 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2332 2443
2389 : normalise $_ 2500 : normalise $_
2390 } @{ aio_readdir $UNIQUEDIR or [] } 2501 } @{ aio_readdir $UNIQUEDIR or [] }
2391 ] 2502 ]
2392} 2503}
2393 2504
2505=item cf::map::static_maps
2506
2507Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2508file in the shared directory excluding F</styles> and F</editor>). May
2509block.
2510
2511=cut
2512
2513sub static_maps() {
2514 my @dirs = "";
2515 my @maps;
2516
2517 while (@dirs) {
2518 my $dir = shift @dirs;
2519
2520 next if $dir eq "/styles" || $dir eq "/editor";
2521
2522 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2523 or return;
2524
2525 for (@$files) {
2526 s/\.map$// or next;
2527 utf8::decode $_;
2528 push @maps, "$dir/$_";
2529 }
2530
2531 push @dirs, map "$dir/$_", @$dirs;
2532 }
2533
2534 \@maps
2535}
2536
2394=back 2537=back
2395 2538
2396=head3 cf::object 2539=head3 cf::object
2397 2540
2398=cut 2541=cut
2463 2606
2464our $SAY_CHANNEL = { 2607our $SAY_CHANNEL = {
2465 id => "say", 2608 id => "say",
2466 title => "Map", 2609 title => "Map",
2467 reply => "say ", 2610 reply => "say ",
2468 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2611 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2469}; 2612};
2470 2613
2471our $CHAT_CHANNEL = { 2614our $CHAT_CHANNEL = {
2472 id => "chat", 2615 id => "chat",
2473 title => "Chat", 2616 title => "Chat",
2528 2671
2529=item $player_object->enter_link 2672=item $player_object->enter_link
2530 2673
2531Freezes the player and moves him/her to a special map (C<{link}>). 2674Freezes the player and moves him/her to a special map (C<{link}>).
2532 2675
2533The player should be reasonably safe there for short amounts of time. You 2676The player should be reasonably safe there for short amounts of time (e.g.
2534I<MUST> call C<leave_link> as soon as possible, though. 2677for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2678though, as the player cannot control the character while it is on the link
2679map.
2535 2680
2536Will never block. 2681Will never block.
2537 2682
2538=item $player_object->leave_link ($map, $x, $y) 2683=item $player_object->leave_link ($map, $x, $y)
2539 2684
2559sub cf::object::player::enter_link { 2704sub cf::object::player::enter_link {
2560 my ($self) = @_; 2705 my ($self) = @_;
2561 2706
2562 $self->deactivate_recursive; 2707 $self->deactivate_recursive;
2563 2708
2709 ++$self->{_link_recursion};
2710
2564 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2711 return if UNIVERSAL::isa $self->map, "ext::map_link";
2565 2712
2566 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2713 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2567 if $self->map && $self->map->{path} ne "{link}"; 2714 if $self->map && $self->map->{path} ne "{link}";
2568 2715
2569 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2716 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2570} 2717}
2571 2718
2572sub cf::object::player::leave_link { 2719sub cf::object::player::leave_link {
2573 my ($self, $map, $x, $y) = @_; 2720 my ($self, $map, $x, $y) = @_;
2574 2721
2591 ($x, $y) = (-1, -1) 2738 ($x, $y) = (-1, -1)
2592 unless (defined $x) && (defined $y); 2739 unless (defined $x) && (defined $y);
2593 2740
2594 # use -1 or undef as default coordinates, not 0, 0 2741 # use -1 or undef as default coordinates, not 0, 0
2595 ($x, $y) = ($map->enter_x, $map->enter_y) 2742 ($x, $y) = ($map->enter_x, $map->enter_y)
2596 if $x <=0 && $y <= 0; 2743 if $x <= 0 && $y <= 0;
2597 2744
2598 $map->load; 2745 $map->load;
2599 $map->load_neighbours; 2746 $map->load_neighbours;
2600 2747
2601 return unless $self->contr->active; 2748 return unless $self->contr->active;
2602 $self->activate_recursive;
2603 2749
2604 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2750 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2605 $self->enter_map ($map, $x, $y); 2751 if ($self->enter_map ($map, $x, $y)) {
2606} 2752 # entering was successful
2753 delete $self->{_link_recursion};
2754 # only activate afterwards, to support waiting in hooks
2755 $self->activate_recursive;
2756 }
2607 2757
2758}
2759
2608=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2760=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2609 2761
2610Moves the player to the given map-path and coordinates by first freezing 2762Moves the player to the given map-path and coordinates by first freezing
2611her, loading and preparing them map, calling the provided $check callback 2763her, loading and preparing them map, calling the provided $check callback
2612that has to return the map if sucecssful, and then unfreezes the player on 2764that has to return the map if sucecssful, and then unfreezes the player on
2613the new (success) or old (failed) map position. In either case, $done will 2765the new (success) or old (failed) map position. In either case, $done will
2614be called at the end of this process. 2766be called at the end of this process.
2615 2767
2768Note that $check will be called with a potentially non-loaded map, so if
2769it needs a loaded map it has to call C<< ->load >>.
2770
2616=cut 2771=cut
2617 2772
2618our $GOTOGEN; 2773our $GOTOGEN;
2619 2774
2620sub cf::object::player::goto { 2775sub cf::object::player::goto {
2621 my ($self, $path, $x, $y, $check, $done) = @_; 2776 my ($self, $path, $x, $y, $check, $done) = @_;
2777
2778 if ($self->{_link_recursion} >= $MAX_LINKS) {
2779 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2780 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2781 ($path, $x, $y) = @$EMERGENCY_POSITION;
2782 }
2622 2783
2623 # do generation counting so two concurrent goto's will be executed in-order 2784 # do generation counting so two concurrent goto's will be executed in-order
2624 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2785 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2625 2786
2626 $self->enter_link; 2787 $self->enter_link;
2650 my $map = eval { 2811 my $map = eval {
2651 my $map = defined $path ? cf::map::find $path : undef; 2812 my $map = defined $path ? cf::map::find $path : undef;
2652 2813
2653 if ($map) { 2814 if ($map) {
2654 $map = $map->customise_for ($self); 2815 $map = $map->customise_for ($self);
2655 $map = $check->($map) if $check && $map; 2816 $map = $check->($map, $x, $y, $self) if $check && $map;
2656 } else { 2817 } else {
2657 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2818 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2658 } 2819 }
2659 2820
2660 $map 2821 $map
2668 if ($gen == $self->{_goto_generation}) { 2829 if ($gen == $self->{_goto_generation}) {
2669 delete $self->{_goto_generation}; 2830 delete $self->{_goto_generation};
2670 $self->leave_link ($map, $x, $y); 2831 $self->leave_link ($map, $x, $y);
2671 } 2832 }
2672 2833
2673 $done->() if $done; 2834 $done->($self) if $done;
2674 })->prio (1); 2835 })->prio (1);
2675} 2836}
2676 2837
2677=item $player_object->enter_exit ($exit_object) 2838=item $player_object->enter_exit ($exit_object)
2678 2839
2698} 2859}
2699 2860
2700sub prepare_random_map { 2861sub prepare_random_map {
2701 my ($exit) = @_; 2862 my ($exit) = @_;
2702 2863
2703 my $guard = cf::lock_acquire "exit_prepare:$exit";
2704
2705 # all this does is basically replace the /! path by 2864 # all this does is basically replace the /! path by
2706 # a new random map path (?random/...) with a seed 2865 # a new random map path (?random/...) with a seed
2707 # that depends on the exit object 2866 # that depends on the exit object
2708 2867
2709 my $rmp = parse_random_map_params $exit->msg; 2868 my $rmp = parse_random_map_params $exit->msg;
2711 if ($exit->map) { 2870 if ($exit->map) {
2712 $rmp->{region} = $exit->region->name; 2871 $rmp->{region} = $exit->region->name;
2713 $rmp->{origin_map} = $exit->map->path; 2872 $rmp->{origin_map} = $exit->map->path;
2714 $rmp->{origin_x} = $exit->x; 2873 $rmp->{origin_x} = $exit->x;
2715 $rmp->{origin_y} = $exit->y; 2874 $rmp->{origin_y} = $exit->y;
2875
2876 $exit->map->touch;
2716 } 2877 }
2717 2878
2718 $rmp->{random_seed} ||= $exit->random_seed; 2879 $rmp->{random_seed} ||= $exit->random_seed;
2719 2880
2720 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp); 2881 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2724 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2885 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2725 aio_write $fh, 0, (length $data), $data, 0; 2886 aio_write $fh, 0, (length $data), $data, 0;
2726 undef $fh; 2887 undef $fh;
2727 aio_rename "$meta~", $meta; 2888 aio_rename "$meta~", $meta;
2728 2889
2890 my $slaying = "?random/$md5";
2891
2892 if ($exit->valid) {
2729 $exit->slaying ("?random/$md5"); 2893 $exit->slaying ("?random/$md5");
2730 $exit->msg (undef); 2894 $exit->msg (undef);
2895 }
2731 } 2896 }
2732} 2897}
2733 2898
2734sub cf::object::player::enter_exit { 2899sub cf::object::player::enter_exit {
2735 my ($self, $exit) = @_; 2900 my ($self, $exit) = @_;
2736 2901
2737 return unless $self->type == cf::PLAYER; 2902 return unless $self->type == cf::PLAYER;
2738 2903
2739 if ($exit->slaying eq "/!") {
2740 #TODO: this should de-fi-ni-te-ly not be a sync-job
2741 # the problem is that $exit might not survive long enough
2742 # so it needs to be done right now, right here
2743 cf::sync_job { prepare_random_map $exit };
2744 }
2745
2746 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2747 my $hp = $exit->stats->hp;
2748 my $sp = $exit->stats->sp;
2749
2750 $self->enter_link; 2904 $self->enter_link;
2751 2905
2752 # if exit is damned, update players death & WoR home-position
2753 $self->contr->savebed ($slaying, $hp, $sp)
2754 if $exit->flag (FLAG_DAMNED);
2755
2756 (async { 2906 (async {
2757 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2907 $Coro::current->{desc} = "enter_exit";
2758 2908
2759 $self->deactivate_recursive; # just to be sure
2760 unless (eval { 2909 unless (eval {
2910 $self->deactivate_recursive; # just to be sure
2911
2912 # random map handling
2913 {
2914 my $guard = cf::lock_acquire "exit_prepare:$exit";
2915
2916 prepare_random_map $exit
2917 if $exit->slaying eq "/!";
2918 }
2919
2920 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2921 my $x = $exit->stats->hp;
2922 my $y = $exit->stats->sp;
2923
2761 $self->goto ($slaying, $hp, $sp); 2924 $self->goto ($map, $x, $y);
2762 2925
2926 # if exit is damned, update players death & WoR home-position
2927 $self->contr->savebed ($map, $x, $y)
2928 if $exit->flag (cf::FLAG_DAMNED);
2929
2763 1; 2930 1
2764 }) { 2931 }) {
2765 $self->message ("Something went wrong deep within the crossfire server. " 2932 $self->message ("Something went wrong deep within the deliantra server. "
2766 . "I'll try to bring you back to the map you were before. " 2933 . "I'll try to bring you back to the map you were before. "
2767 . "Please report this to the dungeon master!", 2934 . "Please report this to the dungeon master!",
2768 cf::NDI_UNIQUE | cf::NDI_RED); 2935 cf::NDI_UNIQUE | cf::NDI_RED);
2769 2936
2770 warn "ERROR in enter_exit: $@"; 2937 error "ERROR in enter_exit: $@";
2771 $self->leave_link; 2938 $self->leave_link;
2772 } 2939 }
2773 })->prio (1); 2940 })->prio (1);
2774} 2941}
2775 2942
2787sub cf::client::send_drawinfo { 2954sub cf::client::send_drawinfo {
2788 my ($self, $text, $flags) = @_; 2955 my ($self, $text, $flags) = @_;
2789 2956
2790 utf8::encode $text; 2957 utf8::encode $text;
2791 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2958 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2959}
2960
2961=item $client->send_big_packet ($pkt)
2962
2963Like C<send_packet>, but tries to compress large packets, and fragments
2964them as required.
2965
2966=cut
2967
2968our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2969
2970sub cf::client::send_big_packet {
2971 my ($self, $pkt) = @_;
2972
2973 # try lzf for large packets
2974 $pkt = "lzf " . Compress::LZF::compress $pkt
2975 if 1024 <= length $pkt and $self->{can_lzf};
2976
2977 # split very large packets
2978 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2979 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2980 $pkt = "frag";
2981 }
2982
2983 $self->send_packet ($pkt);
2792} 2984}
2793 2985
2794=item $client->send_msg ($channel, $msg, $color, [extra...]) 2986=item $client->send_msg ($channel, $msg, $color, [extra...])
2795 2987
2796Send a drawinfo or msg packet to the client, formatting the msg for the 2988Send a drawinfo or msg packet to the client, formatting the msg for the
2800 2992
2801=cut 2993=cut
2802 2994
2803# non-persistent channels (usually the info channel) 2995# non-persistent channels (usually the info channel)
2804our %CHANNEL = ( 2996our %CHANNEL = (
2997 "c/motd" => {
2998 id => "infobox",
2999 title => "MOTD",
3000 reply => undef,
3001 tooltip => "The message of the day",
3002 },
2805 "c/identify" => { 3003 "c/identify" => {
2806 id => "infobox", 3004 id => "infobox",
2807 title => "Identify", 3005 title => "Identify",
2808 reply => undef, 3006 reply => undef,
2809 tooltip => "Items recently identified", 3007 tooltip => "Items recently identified",
2811 "c/examine" => { 3009 "c/examine" => {
2812 id => "infobox", 3010 id => "infobox",
2813 title => "Examine", 3011 title => "Examine",
2814 reply => undef, 3012 reply => undef,
2815 tooltip => "Signs and other items you examined", 3013 tooltip => "Signs and other items you examined",
3014 },
3015 "c/shopinfo" => {
3016 id => "infobox",
3017 title => "Shop Info",
3018 reply => undef,
3019 tooltip => "What your bargaining skill tells you about the shop",
2816 }, 3020 },
2817 "c/book" => { 3021 "c/book" => {
2818 id => "infobox", 3022 id => "infobox",
2819 title => "Book", 3023 title => "Book",
2820 reply => undef, 3024 reply => undef,
2836 id => "infobox", 3040 id => "infobox",
2837 title => "Body Parts", 3041 title => "Body Parts",
2838 reply => undef, 3042 reply => undef,
2839 tooltip => "Shows which body parts you posess and are available", 3043 tooltip => "Shows which body parts you posess and are available",
2840 }, 3044 },
3045 "c/statistics" => {
3046 id => "infobox",
3047 title => "Statistics",
3048 reply => undef,
3049 tooltip => "Shows your primary statistics",
3050 },
3051 "c/skills" => {
3052 id => "infobox",
3053 title => "Skills",
3054 reply => undef,
3055 tooltip => "Shows your experience per skill and item power",
3056 },
3057 "c/shopitems" => {
3058 id => "infobox",
3059 title => "Shop Items",
3060 reply => undef,
3061 tooltip => "Shows the items currently for sale in this shop",
3062 },
3063 "c/resistances" => {
3064 id => "infobox",
3065 title => "Resistances",
3066 reply => undef,
3067 tooltip => "Shows your resistances",
3068 },
3069 "c/pets" => {
3070 id => "infobox",
3071 title => "Pets",
3072 reply => undef,
3073 tooltip => "Shows information abotu your pets/a specific pet",
3074 },
3075 "c/perceiveself" => {
3076 id => "infobox",
3077 title => "Perceive Self",
3078 reply => undef,
3079 tooltip => "You gained detailed knowledge about yourself",
3080 },
2841 "c/uptime" => { 3081 "c/uptime" => {
2842 id => "infobox", 3082 id => "infobox",
2843 title => "Uptime", 3083 title => "Uptime",
2844 reply => undef, 3084 reply => undef,
2845 tooltip => "How long the server has been running since last restart", 3085 tooltip => "How long the server has been running since last restart",
2854 id => "party", 3094 id => "party",
2855 title => "Party", 3095 title => "Party",
2856 reply => "gsay ", 3096 reply => "gsay ",
2857 tooltip => "Messages and chat related to your party", 3097 tooltip => "Messages and chat related to your party",
2858 }, 3098 },
3099 "c/death" => {
3100 id => "death",
3101 title => "Death",
3102 reply => undef,
3103 tooltip => "Reason for and more info about your most recent death",
3104 },
3105 "c/say" => $SAY_CHANNEL,
3106 "c/chat" => $CHAT_CHANNEL,
2859); 3107);
2860 3108
2861sub cf::client::send_msg { 3109sub cf::client::send_msg {
2862 my ($self, $channel, $msg, $color, @extra) = @_; 3110 my ($self, $channel, $msg, $color, @extra) = @_;
2863 3111
2864 $msg = $self->pl->expand_cfpod ($msg); 3112 $msg = $self->pl->expand_cfpod ($msg)
3113 unless $color & cf::NDI_VERBATIM;
2865 3114
2866 $color &= cf::NDI_CLIENT_MASK; # just in case... 3115 $color &= cf::NDI_CLIENT_MASK; # just in case...
2867 3116
2868 # check predefined channels, for the benefit of C 3117 # check predefined channels, for the benefit of C
2869 if ($CHANNEL{$channel}) { 3118 if ($CHANNEL{$channel}) {
2870 $channel = $CHANNEL{$channel}; 3119 $channel = $CHANNEL{$channel};
2871 3120
2872 $self->ext_msg (channel_info => $channel) 3121 $self->ext_msg (channel_info => $channel);
2873 if $self->can_msg;
2874
2875 $channel = $channel->{id}; 3122 $channel = $channel->{id};
2876 3123
2877 } elsif (ref $channel) { 3124 } elsif (ref $channel) {
2878 # send meta info to client, if not yet sent 3125 # send meta info to client, if not yet sent
2879 unless (exists $self->{channel}{$channel->{id}}) { 3126 unless (exists $self->{channel}{$channel->{id}}) {
2880 $self->{channel}{$channel->{id}} = $channel; 3127 $self->{channel}{$channel->{id}} = $channel;
2881 $self->ext_msg (channel_info => $channel) 3128 $self->ext_msg (channel_info => $channel);
2882 if $self->can_msg;
2883 } 3129 }
2884 3130
2885 $channel = $channel->{id}; 3131 $channel = $channel->{id};
2886 } 3132 }
2887 3133
2888 return unless @extra || length $msg; 3134 return unless @extra || length $msg;
2889 3135
2890 if ($self->can_msg) {
2891 # default colour, mask it out 3136 # default colour, mask it out
2892 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3137 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2893 if $color & cf::NDI_DEF; 3138 if $color & cf::NDI_DEF;
2894 3139
2895 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3140 my $pkt = "msg "
3141 . $self->{json_coder}->encode (
2896 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3142 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2897 } else { 3143 );
2898 if ($color >= 0) {
2899 # replace some tags by gcfclient-compatible ones
2900 for ($msg) {
2901 1 while
2902 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2903 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2904 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2905 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2906 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2907 }
2908 3144
2909 $color &= cf::NDI_COLOR_MASK; 3145 $self->send_big_packet ($pkt);
2910
2911 utf8::encode $msg;
2912
2913 if (0 && $msg =~ /\[/) {
2914 # COMMAND/INFO
2915 $self->send_packet ("drawextinfo $color 10 8 $msg")
2916 } else {
2917 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2918 $self->send_packet ("drawinfo $color $msg")
2919 }
2920 }
2921 }
2922} 3146}
2923 3147
2924=item $client->ext_msg ($type, @msg) 3148=item $client->ext_msg ($type, @msg)
2925 3149
2926Sends an ext event to the client. 3150Sends an ext event to the client.
2929 3153
2930sub cf::client::ext_msg($$@) { 3154sub cf::client::ext_msg($$@) {
2931 my ($self, $type, @msg) = @_; 3155 my ($self, $type, @msg) = @_;
2932 3156
2933 if ($self->extcmd == 2) { 3157 if ($self->extcmd == 2) {
2934 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3158 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2935 } elsif ($self->extcmd == 1) { # TODO: remove 3159 } elsif ($self->extcmd == 1) { # TODO: remove
2936 push @msg, msgtype => "event_$type"; 3160 push @msg, msgtype => "event_$type";
2937 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3161 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2938 } 3162 }
2939} 3163}
2940 3164
2941=item $client->ext_reply ($msgid, @msg) 3165=item $client->ext_reply ($msgid, @msg)
2942 3166
2946 3170
2947sub cf::client::ext_reply($$@) { 3171sub cf::client::ext_reply($$@) {
2948 my ($self, $id, @msg) = @_; 3172 my ($self, $id, @msg) = @_;
2949 3173
2950 if ($self->extcmd == 2) { 3174 if ($self->extcmd == 2) {
2951 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3175 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2952 } elsif ($self->extcmd == 1) { 3176 } elsif ($self->extcmd == 1) {
2953 #TODO: version 1, remove 3177 #TODO: version 1, remove
2954 unshift @msg, msgtype => "reply", msgid => $id; 3178 unshift @msg, msgtype => "reply", msgid => $id;
2955 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3179 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2956 } 3180 }
2957} 3181}
2958 3182
2959=item $success = $client->query ($flags, "text", \&cb) 3183=item $success = $client->query ($flags, "text", \&cb)
2960 3184
3031 3255
3032 $ns->ext_reply ($reply, @reply) 3256 $ns->ext_reply ($reply, @reply)
3033 if $reply; 3257 if $reply;
3034 3258
3035 } else { 3259 } else {
3036 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3260 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3037 } 3261 }
3038 3262
3039 cf::override; 3263 cf::override;
3040 }, 3264 },
3041); 3265);
3061 3285
3062 $coro 3286 $coro
3063} 3287}
3064 3288
3065cf::client->attach ( 3289cf::client->attach (
3066 on_destroy => sub { 3290 on_client_destroy => sub {
3067 my ($ns) = @_; 3291 my ($ns) = @_;
3068 3292
3069 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3293 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3070 }, 3294 },
3071); 3295);
3087our $safe_hole = new Safe::Hole; 3311our $safe_hole = new Safe::Hole;
3088 3312
3089$SIG{FPE} = 'IGNORE'; 3313$SIG{FPE} = 'IGNORE';
3090 3314
3091$safe->permit_only (Opcode::opset qw( 3315$safe->permit_only (Opcode::opset qw(
3092 :base_core :base_mem :base_orig :base_math 3316 :base_core :base_mem :base_orig :base_math :base_loop
3093 grepstart grepwhile mapstart mapwhile 3317 grepstart grepwhile mapstart mapwhile
3094 sort time 3318 sort time
3095)); 3319));
3096 3320
3097# here we export the classes and methods available to script code 3321# here we export the classes and methods available to script code
3101The following functions and methods are available within a safe environment: 3325The following functions and methods are available within a safe environment:
3102 3326
3103 cf::object 3327 cf::object
3104 contr pay_amount pay_player map x y force_find force_add destroy 3328 contr pay_amount pay_player map x y force_find force_add destroy
3105 insert remove name archname title slaying race decrease split 3329 insert remove name archname title slaying race decrease split
3330 value
3106 3331
3107 cf::object::player 3332 cf::object::player
3108 player 3333 player
3109 3334
3110 cf::player 3335 cf::player
3115 3340
3116=cut 3341=cut
3117 3342
3118for ( 3343for (
3119 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3344 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3120 insert remove inv name archname title slaying race 3345 insert remove inv nrof name archname title slaying race
3121 decrease split destroy)], 3346 decrease split destroy change_exp value msg lore send_msg)],
3122 ["cf::object::player" => qw(player)], 3347 ["cf::object::player" => qw(player)],
3123 ["cf::player" => qw(peaceful)], 3348 ["cf::player" => qw(peaceful send_msg)],
3124 ["cf::map" => qw(trigger)], 3349 ["cf::map" => qw(trigger)],
3125) { 3350) {
3126 no strict 'refs';
3127 my ($pkg, @funs) = @$_; 3351 my ($pkg, @funs) = @$_;
3128 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3352 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3129 for @funs; 3353 for @funs;
3130} 3354}
3131 3355
3146 3370
3147 my $qcode = $code; 3371 my $qcode = $code;
3148 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3372 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3149 $qcode =~ s/\n/\\n/g; 3373 $qcode =~ s/\n/\\n/g;
3150 3374
3375 %vars = (_dummy => 0) unless %vars;
3376
3377 my @res;
3151 local $_; 3378 local $_;
3152 local @safe::cf::_safe_eval_args = values %vars;
3153 3379
3154 my $eval = 3380 my $eval =
3155 "do {\n" 3381 "do {\n"
3156 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3382 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3157 . "#line 0 \"{$qcode}\"\n" 3383 . "#line 0 \"{$qcode}\"\n"
3158 . $code 3384 . $code
3159 . "\n}" 3385 . "\n}"
3160 ; 3386 ;
3161 3387
3388 if ($CFG{safe_eval}) {
3162 sub_generation_inc; 3389 sub_generation_inc;
3390 local @safe::cf::_safe_eval_args = values %vars;
3163 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3391 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3164 sub_generation_inc; 3392 sub_generation_inc;
3393 } else {
3394 local @cf::_safe_eval_args = values %vars;
3395 @res = wantarray ? eval eval : scalar eval $eval;
3396 }
3165 3397
3166 if ($@) { 3398 if ($@) {
3167 warn "$@"; 3399 warn "$@",
3168 warn "while executing safe code '$code'\n"; 3400 "while executing safe code '$code'\n",
3169 warn "with arguments " . (join " ", %vars) . "\n"; 3401 "with arguments " . (join " ", %vars) . "\n";
3170 } 3402 }
3171 3403
3172 wantarray ? @res : $res[0] 3404 wantarray ? @res : $res[0]
3173} 3405}
3174 3406
3188=cut 3420=cut
3189 3421
3190sub register_script_function { 3422sub register_script_function {
3191 my ($fun, $cb) = @_; 3423 my ($fun, $cb) = @_;
3192 3424
3193 no strict 'refs'; 3425 $fun = "safe::$fun" if $CFG{safe_eval};
3194 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3426 *$fun = $safe_hole->wrap ($cb);
3195} 3427}
3196 3428
3197=back 3429=back
3198 3430
3199=cut 3431=cut
3208 # for this (global event?) 3440 # for this (global event?)
3209 %ext::player_env::MUSIC_FACE_CACHE = (); 3441 %ext::player_env::MUSIC_FACE_CACHE = ();
3210 3442
3211 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3443 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3212 3444
3213 warn "loading facedata from $path\n"; 3445 trace "loading facedata from $path\n";
3214 3446
3215 my $facedata; 3447 my $facedata = decode_storable load_file $path;
3216 0 < aio_load $path, $facedata
3217 or die "$path: $!";
3218
3219 $facedata = Coro::Storable::thaw $facedata;
3220 3448
3221 $facedata->{version} == 2 3449 $facedata->{version} == 2
3222 or cf::cleanup "$path: version mismatch, cannot proceed."; 3450 or cf::cleanup "$path: version mismatch, cannot proceed.";
3223 3451
3224 # patch in the exptable 3452 # patch in the exptable
3453 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3225 $facedata->{resource}{"res/exp_table"} = { 3454 $facedata->{resource}{"res/exp_table"} = {
3226 type => FT_RSRC, 3455 type => FT_RSRC,
3227 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3456 data => $exp_table,
3457 hash => (Digest::MD5::md5 $exp_table),
3228 }; 3458 };
3229 cf::cede_to_tick; 3459 cf::cede_to_tick;
3230 3460
3231 { 3461 {
3232 my $faces = $facedata->{faceinfo}; 3462 my $faces = $facedata->{faceinfo};
3234 while (my ($face, $info) = each %$faces) { 3464 while (my ($face, $info) = each %$faces) {
3235 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3465 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3236 3466
3237 cf::face::set_visibility $idx, $info->{visibility}; 3467 cf::face::set_visibility $idx, $info->{visibility};
3238 cf::face::set_magicmap $idx, $info->{magicmap}; 3468 cf::face::set_magicmap $idx, $info->{magicmap};
3239 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3469 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3240 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3470 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3471 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3241 3472
3242 cf::cede_to_tick; 3473 cf::cede_to_tick;
3243 } 3474 }
3244 3475
3245 while (my ($face, $info) = each %$faces) { 3476 while (my ($face, $info) = each %$faces) {
3250 3481
3251 if (my $smooth = cf::face::find $info->{smooth}) { 3482 if (my $smooth = cf::face::find $info->{smooth}) {
3252 cf::face::set_smooth $idx, $smooth; 3483 cf::face::set_smooth $idx, $smooth;
3253 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3484 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3254 } else { 3485 } else {
3255 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3486 error "smooth face '$info->{smooth}' not found for face '$face'";
3256 } 3487 }
3257 3488
3258 cf::cede_to_tick; 3489 cf::cede_to_tick;
3259 } 3490 }
3260 } 3491 }
3269 3500
3270 cf::anim::invalidate_all; # d'oh 3501 cf::anim::invalidate_all; # d'oh
3271 } 3502 }
3272 3503
3273 { 3504 {
3274 # TODO: for gcfclient pleasure, we should give resources
3275 # that gcfclient doesn't grok a >10000 face index.
3276 my $res = $facedata->{resource}; 3505 my $res = $facedata->{resource};
3277 3506
3278 while (my ($name, $info) = each %$res) { 3507 while (my ($name, $info) = each %$res) {
3279 if (defined $info->{type}) { 3508 if (defined $info->{type}) {
3280 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3509 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3281 my $data;
3282 3510
3283 if ($info->{type} & 1) { 3511 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3284 # prepend meta info
3285
3286 my $meta = $enc->encode ({
3287 name => $name,
3288 %{ $info->{meta} || {} },
3289 });
3290
3291 $data = pack "(w/a*)*", $meta, $info->{data};
3292 } else {
3293 $data = $info->{data};
3294 }
3295
3296 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3297 cf::face::set_type $idx, $info->{type}; 3512 cf::face::set_type $idx, $info->{type};
3298 } else { 3513 } else {
3299 $RESOURCE{$name} = $info; 3514 $RESOURCE{$name} = $info; # unused
3300 } 3515 }
3301 3516
3302 cf::cede_to_tick; 3517 cf::cede_to_tick;
3303 } 3518 }
3304 } 3519 }
3305 3520
3306 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3521 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3307 3522
3308 1 3523 1
3309} 3524}
3310
3311cf::global->attach (on_resource_update => sub {
3312 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3313 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3314
3315 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3316 my $sound = $soundconf->{compat}[$_]
3317 or next;
3318
3319 my $face = cf::face::find "sound/$sound->[1]";
3320 cf::sound::set $sound->[0] => $face;
3321 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3322 }
3323
3324 while (my ($k, $v) = each %{$soundconf->{event}}) {
3325 my $face = cf::face::find "sound/$v";
3326 cf::sound::set $k => $face;
3327 }
3328 }
3329});
3330 3525
3331register_exticmd fx_want => sub { 3526register_exticmd fx_want => sub {
3332 my ($ns, $want) = @_; 3527 my ($ns, $want) = @_;
3333 3528
3334 while (my ($k, $v) = each %$want) { 3529 while (my ($k, $v) = each %$want) {
3373sub reload_treasures { 3568sub reload_treasures {
3374 load_resource_file "$DATADIR/treasures" 3569 load_resource_file "$DATADIR/treasures"
3375 or die "unable to load treasurelists\n"; 3570 or die "unable to load treasurelists\n";
3376} 3571}
3377 3572
3573sub reload_sound {
3574 trace "loading sound config from $DATADIR/sound\n";
3575
3576 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3577
3578 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3579 my $sound = $soundconf->{compat}[$_]
3580 or next;
3581
3582 my $face = cf::face::find "sound/$sound->[1]";
3583 cf::sound::set $sound->[0] => $face;
3584 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3585 }
3586
3587 while (my ($k, $v) = each %{$soundconf->{event}}) {
3588 my $face = cf::face::find "sound/$v";
3589 cf::sound::set $k => $face;
3590 }
3591}
3592
3378sub reload_resources { 3593sub reload_resources {
3379 warn "reloading resource files...\n"; 3594 trace "reloading resource files...\n";
3380 3595
3596 reload_exp_table;
3597 reload_materials;
3381 reload_facedata; 3598 reload_facedata;
3599 reload_sound;
3382 reload_archetypes; 3600 reload_archetypes;
3383 reload_regions; 3601 reload_regions;
3384 reload_treasures; 3602 reload_treasures;
3385 3603
3386 warn "finished reloading resource files\n"; 3604 trace "finished reloading resource files\n";
3387}
3388
3389sub init {
3390 my $guard = freeze_mainloop;
3391
3392 reload_resources;
3393} 3605}
3394 3606
3395sub reload_config { 3607sub reload_config {
3396 open my $fh, "<:utf8", "$CONFDIR/config" 3608 trace "reloading config file...\n";
3397 or return;
3398 3609
3399 local $/; 3610 my $config = load_file "$CONFDIR/config";
3400 *CFG = YAML::Load <$fh>; 3611 utf8::decode $config;
3612 *CFG = decode_yaml $config;
3401 3613
3402 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3614 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3403 3615
3404 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3616 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3405 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3617 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3406 3618
3407 if (exists $CFG{mlockall}) { 3619 if (exists $CFG{mlockall}) {
3411 }; 3623 };
3412 warn $@ if $@; 3624 warn $@ if $@;
3413 } 3625 }
3414} 3626}
3415 3627
3628sub pidfile() {
3629 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3630 or die "$PIDFILE: $!";
3631 flock $fh, &Fcntl::LOCK_EX
3632 or die "$PIDFILE: flock: $!";
3633 $fh
3634}
3635
3636# make sure only one server instance is running at any one time
3637sub atomic {
3638 my $fh = pidfile;
3639
3640 my $pid = <$fh>;
3641 kill 9, $pid if $pid > 0;
3642
3643 seek $fh, 0, 0;
3644 print $fh $$;
3645}
3646
3647sub main_loop {
3648 trace "EV::loop starting\n";
3649 if (1) {
3650 EV::loop;
3651 }
3652 trace "EV::loop returned\n";
3653 goto &main_loop unless $REALLY_UNLOOP;
3654}
3655
3416sub main { 3656sub main {
3657 cf::init_globals; # initialise logging
3658
3659 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3660 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3661 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3662 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3663
3664 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3665
3417 # we must not ever block the main coroutine 3666 # we must not ever block the main coroutine
3418 local $Coro::idle = sub { 3667 local $Coro::idle = sub {
3419 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3668 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3420 (async { 3669 (async {
3421 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3670 $Coro::current->{desc} = "IDLE BUG HANDLER";
3422 EV::loop EV::LOOP_ONESHOT; 3671 EV::loop EV::LOOP_ONESHOT;
3423 })->prio (Coro::PRIO_MAX); 3672 })->prio (Coro::PRIO_MAX);
3424 }; 3673 };
3425 3674
3426 { 3675 evthread_start IO::AIO::poll_fileno;
3427 my $guard = freeze_mainloop; 3676
3677 cf::sync_job {
3678 cf::incloader::init ();
3679
3680 cf::init_anim;
3681 cf::init_attackmess;
3682 cf::init_dynamic;
3683
3684 cf::load_settings;
3685
3686 reload_resources;
3428 reload_config; 3687 reload_config;
3429 db_init; 3688 db_init;
3689
3690 cf::init_uuid;
3691 cf::init_signals;
3692 cf::init_skills;
3693
3694 cf::init_beforeplay;
3695
3696 atomic;
3697
3430 load_extensions; 3698 load_extensions;
3431 3699
3432 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3700 utime time, time, $RUNTIMEFILE;
3433 evthread_start IO::AIO::poll_fileno; 3701
3702 # no (long-running) fork's whatsoever before this point(!)
3703 use POSIX ();
3704 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3705
3706 cf::_post_init 0;
3434 } 3707 };
3435 3708
3436 EV::loop; 3709 cf::object::thawer::errors_are_fatal 0;
3710 info "parse errors in files are no longer fatal from this point on.\n";
3711
3712 my $free_main; $free_main = EV::idle sub {
3713 undef $free_main;
3714 undef &main; # free gobs of memory :)
3715 };
3716
3717 goto &main_loop;
3437} 3718}
3438 3719
3439############################################################################# 3720#############################################################################
3440# initialisation and cleanup 3721# initialisation and cleanup
3441 3722
3442# install some emergency cleanup handlers 3723# install some emergency cleanup handlers
3443BEGIN { 3724BEGIN {
3444 our %SIGWATCHER = (); 3725 our %SIGWATCHER = ();
3445 for my $signal (qw(INT HUP TERM)) { 3726 for my $signal (qw(INT HUP TERM)) {
3446 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3727 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3447 cf::cleanup "SIG$signal"; 3728 cf::cleanup "SIG$signal";
3448 }; 3729 };
3449 } 3730 }
3450} 3731}
3451 3732
3452sub write_runtime_sync { 3733sub write_runtime_sync {
3453 my $runtime = "$LOCALDIR/runtime"; 3734 my $t0 = AE::time;
3454 3735
3455 # first touch the runtime file to show we are still running: 3736 # first touch the runtime file to show we are still running:
3456 # the fsync below can take a very very long time. 3737 # the fsync below can take a very very long time.
3457 3738
3458 IO::AIO::aio_utime $runtime, undef, undef; 3739 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3459 3740
3460 my $guard = cf::lock_acquire "write_runtime"; 3741 my $guard = cf::lock_acquire "write_runtime";
3461 3742
3462 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3743 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3463 or return; 3744 or return;
3464 3745
3465 my $value = $cf::RUNTIME + 90 + 10; 3746 my $value = $cf::RUNTIME + 90 + 10;
3466 # 10 is the runtime save interval, for a monotonic clock 3747 # 10 is the runtime save interval, for a monotonic clock
3467 # 60 allows for the watchdog to kill the server. 3748 # 60 allows for the watchdog to kill the server.
3477 aio_utime $fh, undef, undef; 3758 aio_utime $fh, undef, undef;
3478 3759
3479 close $fh 3760 close $fh
3480 or return; 3761 or return;
3481 3762
3482 aio_rename "$runtime~", $runtime 3763 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3483 and return; 3764 and return;
3484 3765
3485 warn "runtime file written.\n"; 3766 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3486 3767
3487 1 3768 1
3488} 3769}
3489 3770
3490our $uuid_lock; 3771our $uuid_lock;
3499 my $uuid = "$LOCALDIR/uuid"; 3780 my $uuid = "$LOCALDIR/uuid";
3500 3781
3501 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 3782 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3502 or return; 3783 or return;
3503 3784
3504 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; 3785 my $value = uuid_seq uuid_cur;
3786
3787 unless ($value) {
3788 info "cowardly refusing to write zero uuid value!\n";
3789 return;
3790 }
3791
3792 my $value = uuid_str $value + $uuid_skip;
3505 $uuid_skip = 0; 3793 $uuid_skip = 0;
3506 3794
3507 (aio_write $fh, 0, (length $value), $value, 0) <= 0 3795 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3508 and return; 3796 and return;
3509 3797
3515 or return; 3803 or return;
3516 3804
3517 aio_rename "$uuid~", $uuid 3805 aio_rename "$uuid~", $uuid
3518 and return; 3806 and return;
3519 3807
3520 warn "uuid file written ($value).\n"; 3808 trace "uuid file written ($value).\n";
3521 3809
3522 1 3810 1
3523 3811
3524} 3812}
3525 3813
3531} 3819}
3532 3820
3533sub emergency_save() { 3821sub emergency_save() {
3534 my $freeze_guard = cf::freeze_mainloop; 3822 my $freeze_guard = cf::freeze_mainloop;
3535 3823
3536 warn "enter emergency perl save\n"; 3824 info "emergency_perl_save: enter\n";
3825
3826 # this is a trade-off: we want to be very quick here, so
3827 # save all maps without fsync, and later call a global sync
3828 # (which in turn might be very very slow)
3829 local $USE_FSYNC = 0;
3537 3830
3538 cf::sync_job { 3831 cf::sync_job {
3832 cf::write_runtime_sync; # external watchdog should not bark
3833
3539 # use a peculiar iteration method to avoid tripping on perl 3834 # use a peculiar iteration method to avoid tripping on perl
3540 # refcount bugs in for. also avoids problems with players 3835 # refcount bugs in for. also avoids problems with players
3541 # and maps saved/destroyed asynchronously. 3836 # and maps saved/destroyed asynchronously.
3542 warn "begin emergency player save\n"; 3837 info "emergency_perl_save: begin player save\n";
3543 for my $login (keys %cf::PLAYER) { 3838 for my $login (keys %cf::PLAYER) {
3544 my $pl = $cf::PLAYER{$login} or next; 3839 my $pl = $cf::PLAYER{$login} or next;
3545 $pl->valid or next; 3840 $pl->valid or next;
3546 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3841 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3547 $pl->save; 3842 $pl->save;
3548 } 3843 }
3549 warn "end emergency player save\n"; 3844 info "emergency_perl_save: end player save\n";
3550 3845
3551 warn "begin emergency map save\n"; 3846 cf::write_runtime_sync; # external watchdog should not bark
3847
3848 info "emergency_perl_save: begin map save\n";
3552 for my $path (keys %cf::MAP) { 3849 for my $path (keys %cf::MAP) {
3553 my $map = $cf::MAP{$path} or next; 3850 my $map = $cf::MAP{$path} or next;
3554 $map->valid or next; 3851 $map->valid or next;
3555 $map->save; 3852 $map->save;
3556 } 3853 }
3557 warn "end emergency map save\n"; 3854 info "emergency_perl_save: end map save\n";
3558 3855
3559 warn "begin emergency database checkpoint\n"; 3856 cf::write_runtime_sync; # external watchdog should not bark
3857
3858 info "emergency_perl_save: begin database checkpoint\n";
3560 BDB::db_env_txn_checkpoint $DB_ENV; 3859 BDB::db_env_txn_checkpoint $DB_ENV;
3561 warn "end emergency database checkpoint\n"; 3860 info "emergency_perl_save: end database checkpoint\n";
3562 3861
3563 warn "begin write uuid\n"; 3862 info "emergency_perl_save: begin write uuid\n";
3564 write_uuid_sync 1; 3863 write_uuid_sync 1;
3565 warn "end write uuid\n"; 3864 info "emergency_perl_save: end write uuid\n";
3865
3866 cf::write_runtime_sync; # external watchdog should not bark
3867
3868 trace "emergency_perl_save: syncing database to disk";
3869 BDB::db_env_txn_checkpoint $DB_ENV;
3870
3871 info "emergency_perl_save: starting sync\n";
3872 IO::AIO::aio_sync sub {
3873 info "emergency_perl_save: finished sync\n";
3874 };
3875
3876 cf::write_runtime_sync; # external watchdog should not bark
3877
3878 trace "emergency_perl_save: flushing outstanding aio requests";
3879 while (IO::AIO::nreqs || BDB::nreqs) {
3880 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3881 }
3882
3883 cf::write_runtime_sync; # external watchdog should not bark
3566 }; 3884 };
3567 3885
3568 warn "leave emergency perl save\n"; 3886 info "emergency_perl_save: leave\n";
3569} 3887}
3570 3888
3571sub post_cleanup { 3889sub post_cleanup {
3572 my ($make_core) = @_; 3890 my ($make_core) = @_;
3573 3891
3892 IO::AIO::flush;
3893
3574 warn Carp::longmess "post_cleanup backtrace" 3894 error Carp::longmess "post_cleanup backtrace"
3575 if $make_core; 3895 if $make_core;
3896
3897 my $fh = pidfile;
3898 unlink $PIDFILE if <$fh> == $$;
3899}
3900
3901# a safer delete_package, copied from Symbol
3902sub clear_package($) {
3903 my $pkg = shift;
3904
3905 # expand to full symbol table name if needed
3906 unless ($pkg =~ /^main::.*::$/) {
3907 $pkg = "main$pkg" if $pkg =~ /^::/;
3908 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3909 $pkg .= '::' unless $pkg =~ /::$/;
3910 }
3911
3912 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3913 my $stem_symtab = *{$stem}{HASH};
3914
3915 defined $stem_symtab and exists $stem_symtab->{$leaf}
3916 or return;
3917
3918 # clear all symbols
3919 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3920 for my $name (keys %$leaf_symtab) {
3921 _gv_clear *{"$pkg$name"};
3922# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3923 }
3576} 3924}
3577 3925
3578sub do_reload_perl() { 3926sub do_reload_perl() {
3579 # can/must only be called in main 3927 # can/must only be called in main
3580 if ($Coro::current != $Coro::main) { 3928 unless (in_main) {
3581 warn "can only reload from main coroutine"; 3929 error "can only reload from main coroutine";
3582 return; 3930 return;
3583 } 3931 }
3584 3932
3585 warn "reloading..."; 3933 return if $RELOAD++;
3586 3934
3587 warn "entering sync_job"; 3935 my $t1 = AE::time;
3588 3936
3937 while ($RELOAD) {
3938 cf::get_slot 0.1, -1, "reload_perl";
3939 info "perl_reload: reloading...";
3940
3941 trace "perl_reload: entering sync_job";
3942
3589 cf::sync_job { 3943 cf::sync_job {
3590 cf::write_runtime_sync; # external watchdog should not bark
3591 cf::emergency_save; 3944 #cf::emergency_save;
3592 cf::write_runtime_sync; # external watchdog should not bark
3593 3945
3594 warn "syncing database to disk";
3595 BDB::db_env_txn_checkpoint $DB_ENV;
3596
3597 # if anything goes wrong in here, we should simply crash as we already saved
3598
3599 warn "flushing outstanding aio requests";
3600 for (;;) {
3601 BDB::flush;
3602 IO::AIO::flush;
3603 Coro::cede_notself;
3604 last unless IO::AIO::nreqs || BDB::nreqs;
3605 warn "iterate...";
3606 }
3607
3608 ++$RELOAD;
3609
3610 warn "cancelling all extension coros"; 3946 trace "perl_reload: cancelling all extension coros";
3611 $_->cancel for values %EXT_CORO; 3947 $_->cancel for values %EXT_CORO;
3612 %EXT_CORO = (); 3948 %EXT_CORO = ();
3613 3949
3614 warn "removing commands"; 3950 trace "perl_reload: removing commands";
3615 %COMMAND = (); 3951 %COMMAND = ();
3616 3952
3617 warn "removing ext/exti commands"; 3953 trace "perl_reload: removing ext/exti commands";
3618 %EXTCMD = (); 3954 %EXTCMD = ();
3619 %EXTICMD = (); 3955 %EXTICMD = ();
3620 3956
3621 warn "unloading/nuking all extensions"; 3957 trace "perl_reload: unloading/nuking all extensions";
3622 for my $pkg (@EXTS) { 3958 for my $pkg (@EXTS) {
3623 warn "... unloading $pkg"; 3959 trace "... unloading $pkg";
3624 3960
3625 if (my $cb = $pkg->can ("unload")) { 3961 if (my $cb = $pkg->can ("unload")) {
3626 eval { 3962 eval {
3627 $cb->($pkg); 3963 $cb->($pkg);
3628 1 3964 1
3629 } or warn "$pkg unloaded, but with errors: $@"; 3965 } or error "$pkg unloaded, but with errors: $@";
3966 }
3967
3968 trace "... clearing $pkg";
3969 clear_package $pkg;
3630 } 3970 }
3631 3971
3632 warn "... nuking $pkg";
3633 Symbol::delete_package $pkg;
3634 }
3635
3636 warn "unloading all perl modules loaded from $LIBDIR"; 3972 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3637 while (my ($k, $v) = each %INC) { 3973 while (my ($k, $v) = each %INC) {
3638 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3974 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3639 3975
3640 warn "... unloading $k"; 3976 trace "... unloading $k";
3641 delete $INC{$k}; 3977 delete $INC{$k};
3642 3978
3643 $k =~ s/\.pm$//; 3979 $k =~ s/\.pm$//;
3644 $k =~ s/\//::/g; 3980 $k =~ s/\//::/g;
3645 3981
3646 if (my $cb = $k->can ("unload_module")) { 3982 if (my $cb = $k->can ("unload_module")) {
3647 $cb->(); 3983 $cb->();
3984 }
3985
3986 clear_package $k;
3648 } 3987 }
3649 3988
3650 Symbol::delete_package $k;
3651 }
3652
3653 warn "getting rid of safe::, as good as possible"; 3989 trace "perl_reload: getting rid of safe::, as good as possible";
3654 Symbol::delete_package "safe::$_" 3990 clear_package "safe::$_"
3655 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3991 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3656 3992
3657 warn "unloading cf.pm \"a bit\""; 3993 trace "perl_reload: unloading cf.pm \"a bit\"";
3658 delete $INC{"cf.pm"}; 3994 delete $INC{"cf.pm"};
3659 delete $INC{"cf/pod.pm"}; 3995 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3660 3996
3661 # don't, removes xs symbols, too, 3997 # don't, removes xs symbols, too,
3662 # and global variables created in xs 3998 # and global variables created in xs
3663 #Symbol::delete_package __PACKAGE__; 3999 #clear_package __PACKAGE__;
3664 4000
3665 warn "unload completed, starting to reload now"; 4001 info "perl_reload: unload completed, starting to reload now";
3666 4002
3667 warn "reloading cf.pm"; 4003 trace "perl_reload: reloading cf.pm";
3668 require cf; 4004 require cf;
3669 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 4005 cf::_connect_to_perl_1;
3670 4006
3671 warn "loading config and database again"; 4007 trace "perl_reload: loading config and database again";
3672 cf::reload_config; 4008 cf::reload_config;
3673 4009
3674 warn "loading extensions"; 4010 trace "perl_reload: loading extensions";
3675 cf::load_extensions; 4011 cf::load_extensions;
3676 4012
4013 if ($REATTACH_ON_RELOAD) {
3677 warn "reattaching attachments to objects/players"; 4014 trace "perl_reload: reattaching attachments to objects/players";
3678 _global_reattach; # objects, sockets 4015 _global_reattach; # objects, sockets
3679 warn "reattaching attachments to maps"; 4016 trace "perl_reload: reattaching attachments to maps";
3680 reattach $_ for values %MAP; 4017 reattach $_ for values %MAP;
3681 warn "reattaching attachments to players"; 4018 trace "perl_reload: reattaching attachments to players";
3682 reattach $_ for values %PLAYER; 4019 reattach $_ for values %PLAYER;
4020 }
3683 4021
3684 warn "leaving sync_job"; 4022 cf::_post_init 1;
3685 4023
4024 trace "perl_reload: leaving sync_job";
4025
3686 1 4026 1
3687 } or do { 4027 } or do {
3688 warn $@; 4028 error $@;
3689 cf::cleanup "error while reloading, exiting."; 4029 cf::cleanup "perl_reload: error, exiting.";
4030 };
4031
4032 --$RELOAD;
3690 }; 4033 }
3691 4034
3692 warn "reloaded"; 4035 $t1 = AE::time - $t1;
4036 info "perl_reload: completed in ${t1}s\n";
3693}; 4037};
3694 4038
3695our $RELOAD_WATCHER; # used only during reload 4039our $RELOAD_WATCHER; # used only during reload
3696 4040
3697sub reload_perl() { 4041sub reload_perl() {
3698 # doing reload synchronously and two reloads happen back-to-back, 4042 # doing reload synchronously and two reloads happen back-to-back,
3699 # coro crashes during coro_state_free->destroy here. 4043 # coro crashes during coro_state_free->destroy here.
3700 4044
4045 $RELOAD_WATCHER ||= cf::async {
4046 Coro::AIO::aio_wait cache_extensions;
4047
3701 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 4048 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3702 do_reload_perl; 4049 do_reload_perl;
3703 undef $RELOAD_WATCHER; 4050 undef $RELOAD_WATCHER;
4051 };
3704 }; 4052 };
3705} 4053}
3706 4054
3707register_command "reload" => sub { 4055register_command "reload" => sub {
3708 my ($who, $arg) = @_; 4056 my ($who, $arg) = @_;
3714 reload_perl; 4062 reload_perl;
3715 }; 4063 };
3716 } 4064 }
3717}; 4065};
3718 4066
3719unshift @INC, $LIBDIR; 4067#############################################################################
3720 4068
3721my $bug_warning = 0; 4069my $bug_warning = 0;
3722 4070
3723our @WAIT_FOR_TICK; 4071our @WAIT_FOR_TICK;
3724our @WAIT_FOR_TICK_BEGIN; 4072our @WAIT_FOR_TICK_BEGIN;
3725 4073
3726sub wait_for_tick { 4074sub wait_for_tick() {
3727 return if tick_inhibit || $Coro::current == $Coro::main; 4075 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3728 4076
3729 my $signal = new Coro::Signal; 4077 my $signal = new Coro::Signal;
3730 push @WAIT_FOR_TICK, $signal; 4078 push @WAIT_FOR_TICK, $signal;
3731 $signal->wait; 4079 $signal->wait;
3732} 4080}
3733 4081
3734sub wait_for_tick_begin { 4082sub wait_for_tick_begin() {
3735 return if tick_inhibit || $Coro::current == $Coro::main; 4083 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3736 4084
3737 my $signal = new Coro::Signal; 4085 my $signal = new Coro::Signal;
3738 push @WAIT_FOR_TICK_BEGIN, $signal; 4086 push @WAIT_FOR_TICK_BEGIN, $signal;
3739 $signal->wait; 4087 $signal->wait;
3740} 4088}
3746 return; 4094 return;
3747 } 4095 }
3748 4096
3749 cf::server_tick; # one server iteration 4097 cf::server_tick; # one server iteration
3750 4098
4099 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4100
3751 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4101 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3752 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4102 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3753 Coro::async_pool { 4103 Coro::async_pool {
3754 $Coro::current->{desc} = "runtime saver"; 4104 $Coro::current->{desc} = "runtime saver";
3755 write_runtime_sync 4105 write_runtime_sync
3756 or warn "ERROR: unable to write runtime file: $!"; 4106 or error "ERROR: unable to write runtime file: $!";
3757 }; 4107 };
3758 } 4108 }
3759 4109
3760 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4110 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3761 $sig->send; 4111 $sig->send;
3769 4119
3770 if (0) { 4120 if (0) {
3771 if ($NEXT_TICK) { 4121 if ($NEXT_TICK) {
3772 my $jitter = $TICK_START - $NEXT_TICK; 4122 my $jitter = $TICK_START - $NEXT_TICK;
3773 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4123 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3774 warn "jitter $JITTER\n";#d# 4124 debug "jitter $JITTER\n";#d#
3775 } 4125 }
3776 } 4126 }
3777} 4127}
3778 4128
3779{ 4129{
3780 # configure BDB 4130 # configure BDB
3781 4131
3782 BDB::min_parallel 8; 4132 BDB::min_parallel 16;
3783 BDB::max_poll_reqs $TICK * 0.1; 4133 BDB::max_poll_reqs $TICK * 0.1;
3784 $Coro::BDB::WATCHER->priority (1); 4134 $AnyEvent::BDB::WATCHER->priority (1);
3785 4135
3786 unless ($DB_ENV) { 4136 unless ($DB_ENV) {
3787 $DB_ENV = BDB::db_env_create; 4137 $DB_ENV = BDB::db_env_create;
3788 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 4138 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3789 | BDB::LOG_AUTOREMOVE, 1); 4139 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4140 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3790 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 4141 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3791 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 4142 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3792 4143
3793 cf::sync_job { 4144 cf::sync_job {
3794 eval { 4145 eval {
3820{ 4171{
3821 # configure IO::AIO 4172 # configure IO::AIO
3822 4173
3823 IO::AIO::min_parallel 8; 4174 IO::AIO::min_parallel 8;
3824 IO::AIO::max_poll_time $TICK * 0.1; 4175 IO::AIO::max_poll_time $TICK * 0.1;
3825 $Coro::AIO::WATCHER->priority (1); 4176 undef $AnyEvent::AIO::WATCHER;
3826} 4177}
3827 4178
3828my $_log_backtrace; 4179our $_log_backtrace;
4180our $_log_backtrace_last;
3829 4181
3830sub _log_backtrace { 4182sub _log_backtrace {
3831 my ($msg, @addr) = @_; 4183 my ($msg, @addr) = @_;
3832 4184
3833 $msg =~ s/\n//; 4185 $msg =~ s/\n$//;
3834 4186
4187 if ($_log_backtrace_last eq $msg) {
4188 LOG llevInfo, "[ABT] $msg\n";
4189 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
3835 # limit the # of concurrent backtraces 4190 # limit the # of concurrent backtraces
3836 if ($_log_backtrace < 2) { 4191 } elsif ($_log_backtrace < 2) {
4192 $_log_backtrace_last = $msg;
3837 ++$_log_backtrace; 4193 ++$_log_backtrace;
4194 my $perl_bt = Carp::longmess $msg;
3838 async { 4195 async {
3839 $Coro::current->{desc} = "abt $msg"; 4196 $Coro::current->{desc} = "abt $msg";
3840 4197
3841 my @bt = fork_call { 4198 my @bt = fork_call {
3842 @addr = map { sprintf "%x", $_ } @addr; 4199 @addr = map { sprintf "%x", $_ } @addr;
3853 } 4210 }
3854 4211
3855 @funcs 4212 @funcs
3856 }; 4213 };
3857 4214
3858 LOG llevInfo, "[ABT] $msg\n"; 4215 LOG llevInfo, "[ABT] $perl_bt\n";
4216 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3859 LOG llevInfo, "[ABT] $_\n" for @bt; 4217 LOG llevInfo, "[ABT] $_\n" for @bt;
3860 --$_log_backtrace; 4218 --$_log_backtrace;
3861 }; 4219 };
3862 } else { 4220 } else {
3863 LOG llevInfo, "[ABT] $msg\n"; 4221 LOG llevInfo, "[ABT] $msg\n";
3864 LOG llevInfo, "[ABT] [suppressed]\n"; 4222 LOG llevInfo, "[ABT] [overload, suppressed]\n";
3865 } 4223 }
3866} 4224}
3867 4225
3868# load additional modules 4226# load additional modules
3869use cf::pod; 4227require "cf/$_.pm" for @EXTRA_MODULES;
4228cf::_connect_to_perl_2;
3870 4229
3871END { cf::emergency_save } 4230END { cf::emergency_save }
3872 4231
38731 42321
3874 4233

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines