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.433 by root, Sat May 10 22:38:52 2008 UTC vs.
Revision 1.540 by root, Tue May 4 23:32:29 2010 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; 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 (); 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;
43use Coro::AnyEvent; 47use Coro::AnyEvent;
44use Coro::AIO; 48use Coro::AIO;
45use Coro::BDB; 49use Coro::BDB 1.6;
46use Coro::Storable; 50use Coro::Storable;
47use Coro::Util (); 51use Coro::Util ();
48 52
49use JSON::XS 2.01 (); 53use JSON::XS 2.01 ();
50use BDB (); 54use BDB ();
51use Data::Dumper; 55use Data::Dumper;
52use Digest::MD5;
53use Fcntl; 56use Fcntl;
54use YAML (); 57use YAML::XS ();
55use IO::AIO (); 58use IO::AIO ();
56use Time::HiRes; 59use Time::HiRes;
57use Compress::LZF; 60use Compress::LZF;
58use Digest::MD5 (); 61use Digest::MD5 ();
59 62
… …
61 64
62# configure various modules to our taste 65# configure various modules to our taste
63# 66#
64$Storable::canonical = 1; # reduce rsync transfers 67$Storable::canonical = 1; # reduce rsync transfers
65Coro::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";
66Compress::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
67 75
68$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" };
69 78
70sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
80
81our @ORIG_INC;
71 82
72our %COMMAND = (); 83our %COMMAND = ();
73our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
74 85
75our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
76our %EXTCMD = (); 87our %EXTCMD = ();
77our %EXTICMD = (); 88our %EXTICMD = ();
78our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
79our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
80 91
81our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
82our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
83 96
84our $CONFDIR = confdir; 97our $CONFDIR = confdir;
85our $DATADIR = datadir; 98our $DATADIR = datadir;
86our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
87our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
88our $MAPDIR = "$DATADIR/" . mapdir; 101our $MAPDIR = "$DATADIR/" . mapdir;
89our $LOCALDIR = localdir; 102our $LOCALDIR = localdir;
90our $TMPDIR = "$LOCALDIR/" . tmpdir; 103our $TMPDIR = "$LOCALDIR/" . tmpdir;
91our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
92our $PLAYERDIR = "$LOCALDIR/" . playerdir; 105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
93our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
94our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
95our %RESOURCE; 111our %RESOURCE; # unused
112
113our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 1000000;
115
116our $MAX_LINKS = 32; # how many chained exits to follow
117our $VERBOSE_IO = 1;
96 118
97our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
98our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
99our $NEXT_TICK; 121our $NEXT_TICK;
100our $USE_FSYNC = 1; # use fsync to write maps - default off 122our $USE_FSYNC = 1; # use fsync to write maps - default on
101 123
102our $BDB_DEADLOCK_WATCHER; 124our $BDB_DEADLOCK_WATCHER;
103our $BDB_CHECKPOINT_WATCHER; 125our $BDB_CHECKPOINT_WATCHER;
104our $BDB_TRICKLE_WATCHER; 126our $BDB_TRICKLE_WATCHER;
105our $DB_ENV; 127our $DB_ENV;
106 128
129our @EXTRA_MODULES = qw(pod match mapscript);
130
107our %CFG; 131our %CFG;
108 132
109our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
110our $RUNTIME; 134our $RUNTIME;
111our $NOW; 135our $NOW;
… …
120our $LOAD; # a number between 0 (idle) and 1 (too many objects) 144our $LOAD; # a number between 0 (idle) and 1 (too many objects)
121our $LOADAVG; # same thing, but with alpha-smoothing 145our $LOADAVG; # same thing, but with alpha-smoothing
122our $JITTER; # average jitter 146our $JITTER; # average jitter
123our $TICK_START; # for load detecting purposes 147our $TICK_START; # for load detecting purposes
124 148
149our @POST_INIT;
150
151our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
152our $REALLY_UNLOOP; # never set to true, please :)
153
125binmode STDOUT; 154binmode STDOUT;
126binmode STDERR; 155binmode STDERR;
127 156
128# read virtual server time, if available 157# read virtual server time, if available
129unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 158unless ($RUNTIME || !-e $RUNTIMEFILE) {
130 open my $fh, "<", "$LOCALDIR/runtime" 159 open my $fh, "<", $RUNTIMEFILE
131 or die "unable to read runtime file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
132 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
133} 162}
163
164eval "sub TICK() { $TICK } 1" or die;
134 165
135mkdir $_ 166mkdir $_
136 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
137 168
138our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
139 170
140sub cf::map::normalise; 171sub cf::map::normalise;
172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
176
177#############################################################################
178
179%REFLECT = ();
180for (@REFLECT) {
181 my $reflect = JSON::XS::decode_json $_;
182 $REFLECT{$reflect->{class}} = $reflect;
183}
184
185# this is decidedly evil
186$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
141 187
142############################################################################# 188#############################################################################
143 189
144=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
145 191
… …
192returns directly I<after> the tick processing (and consequently, can only wake one process 238returns directly I<after> the tick processing (and consequently, can only wake one process
193per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 239per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
194 240
195=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
196 242
197This array contains the results of the last C<invoke ()> call. When 243This array contains the results of the last C<invoke ()> call. When
198C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 244C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
199that call. 245that call.
200 246
247=item %cf::REFLECT
248
249Contains, for each (C++) class name, a hash reference with information
250about object members (methods, scalars, arrays and flags) and other
251metadata, which is useful for introspection.
252
201=back 253=back
202 254
203=cut 255=cut
204 256
205BEGIN { 257sub error(@) { LOG llevError, join "", @_ }
206 *CORE::GLOBAL::warn = sub { 258sub warn (@) { LOG llevWarn , join "", @_ }
259sub info (@) { LOG llevInfo , join "", @_ }
260sub debug(@) { LOG llevDebug, join "", @_ }
261sub trace(@) { LOG llevTrace, join "", @_ }
262
263$Coro::State::WARNHOOK = sub {
207 my $msg = join "", @_; 264 my $msg = join "", @_;
208 265
209 $msg .= "\n" 266 $msg .= "\n"
210 unless $msg =~ /\n$/; 267 unless $msg =~ /\n$/;
211 268
212 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 269 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
213 270
214 LOG llevError, $msg; 271 LOG llevWarn, $msg;
215 }; 272};
216}
217 273
218$Coro::State::DIEHOOK = sub { 274$Coro::State::DIEHOOK = sub {
219 return unless $^S eq 0; # "eq", not "==" 275 return unless $^S eq 0; # "eq", not "=="
220 276
221 if ($Coro::current == $Coro::main) {#d# 277 error Carp::longmess $_[0];
278
279 if (in_main) {#d#
222 warn "DIEHOOK called in main context, Coro bug?\n";#d# 280 error "DIEHOOK called in main context, Coro bug?\n";#d#
223 return;#d# 281 return;#d#
224 }#d# 282 }#d#
225 283
226 # kill coroutine otherwise 284 # kill coroutine otherwise
227 warn Carp::longmess $_[0];
228 Coro::terminate 285 Coro::terminate
229}; 286};
230
231$SIG{__DIE__} = sub { }; #d#?
232 287
233@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 288@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
234@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 289@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
235@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 290@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
236@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 291@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
243for my $pkg (qw( 298for my $pkg (qw(
244 cf::global cf::attachable 299 cf::global cf::attachable
245 cf::object cf::object::player 300 cf::object cf::object::player
246 cf::client cf::player 301 cf::client cf::player
247 cf::arch cf::living 302 cf::arch cf::living
303 cf::map cf::mapspace
248 cf::map cf::party cf::region 304 cf::party cf::region
249)) { 305)) {
250 no strict 'refs';
251 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 306 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
252} 307}
253 308
254$EV::DIED = sub { 309$EV::DIED = sub {
255 warn "error in event callback: @_"; 310 Carp::cluck "error in event callback: @_";
256}; 311};
257 312
258############################################################################# 313#############################################################################
259 314
260=head2 UTILITY FUNCTIONS 315=head2 UTILITY FUNCTIONS
… …
297our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 352our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
298 353
299sub encode_json($) { $json_coder->encode ($_[0]) } 354sub encode_json($) { $json_coder->encode ($_[0]) }
300sub decode_json($) { $json_coder->decode ($_[0]) } 355sub decode_json($) { $json_coder->decode ($_[0]) }
301 356
357=item cf::post_init { BLOCK }
358
359Execute the given codeblock, I<after> all extensions have been (re-)loaded,
360but I<before> the server starts ticking again.
361
362The cdoeblock will have a single boolean argument to indicate whether this
363is a reload or not.
364
365=cut
366
367sub post_init(&) {
368 push @POST_INIT, shift;
369}
370
302=item cf::lock_wait $string 371=item cf::lock_wait $string
303 372
304Wait until the given lock is available. See cf::lock_acquire. 373Wait until the given lock is available. See cf::lock_acquire.
305 374
306=item my $lock = cf::lock_acquire $string 375=item my $lock = cf::lock_acquire $string
307 376
308Wait until the given lock is available and then acquires it and returns 377Wait until the given lock is available and then acquires it and returns
309a Coro::guard object. If the guard object gets destroyed (goes out of scope, 378a L<Guard> object. If the guard object gets destroyed (goes out of scope,
310for example when the coroutine gets canceled), the lock is automatically 379for example when the coroutine gets canceled), the lock is automatically
311returned. 380returned.
312 381
313Locks are *not* recursive, locking from the same coro twice results in a 382Locks are *not* recursive, locking from the same coro twice results in a
314deadlocked coro. 383deadlocked coro.
… …
320 389
321Return true if the lock is currently active, i.e. somebody has locked it. 390Return true if the lock is currently active, i.e. somebody has locked it.
322 391
323=cut 392=cut
324 393
325our %LOCK; 394our $LOCKS = new Coro::SemaphoreSet;
326our %LOCKER;#d#
327 395
328sub lock_wait($) { 396sub lock_wait($) {
329 my ($key) = @_; 397 $LOCKS->wait ($_[0]);
330
331 if ($LOCKER{$key} == $Coro::current) {#d#
332 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
333 return;#d#
334 }#d#
335
336 # wait for lock, if any
337 while ($LOCK{$key}) {
338 push @{ $LOCK{$key} }, $Coro::current;
339 Coro::schedule;
340 }
341} 398}
342 399
343sub lock_acquire($) { 400sub lock_acquire($) {
344 my ($key) = @_; 401 $LOCKS->guard ($_[0])
345
346 # wait, to be sure we are not locked
347 lock_wait $key;
348
349 $LOCK{$key} = [];
350 $LOCKER{$key} = $Coro::current;#d#
351
352 Coro::guard {
353 delete $LOCKER{$key};#d#
354 # wake up all waiters, to be on the safe side
355 $_->ready for @{ delete $LOCK{$key} };
356 }
357} 402}
358 403
359sub lock_active($) { 404sub lock_active($) {
360 my ($key) = @_; 405 $LOCKS->count ($_[0]) < 1
361
362 ! ! $LOCK{$key}
363} 406}
364 407
365sub freeze_mainloop { 408sub freeze_mainloop {
366 tick_inhibit_inc; 409 tick_inhibit_inc;
367 410
368 Coro::guard \&tick_inhibit_dec; 411 &Guard::guard (\&tick_inhibit_dec);
369} 412}
370 413
371=item cf::periodic $interval, $cb 414=item cf::periodic $interval, $cb
372 415
373Like EV::periodic, but randomly selects a starting point so that the actions 416Like EV::periodic, but randomly selects a starting point so that the actions
374get spread over timer. 417get spread over time.
375 418
376=cut 419=cut
377 420
378sub periodic($$) { 421sub periodic($$) {
379 my ($interval, $cb) = @_; 422 my ($interval, $cb) = @_;
… …
396 439
397=cut 440=cut
398 441
399our @SLOT_QUEUE; 442our @SLOT_QUEUE;
400our $SLOT_QUEUE; 443our $SLOT_QUEUE;
444our $SLOT_DECAY = 0.9;
401 445
402$SLOT_QUEUE->cancel if $SLOT_QUEUE; 446$SLOT_QUEUE->cancel if $SLOT_QUEUE;
403$SLOT_QUEUE = Coro::async { 447$SLOT_QUEUE = Coro::async {
404 $Coro::current->desc ("timeslot manager"); 448 $Coro::current->desc ("timeslot manager");
405 449
406 my $signal = new Coro::Signal; 450 my $signal = new Coro::Signal;
451 my $busy;
407 452
408 while () { 453 while () {
409 next_job: 454 next_job:
455
410 my $avail = cf::till_tick; 456 my $avail = cf::till_tick;
411 if ($avail > 0.01) { 457
412 for (0 .. $#SLOT_QUEUE) { 458 for (0 .. $#SLOT_QUEUE) {
413 if ($SLOT_QUEUE[$_][0] < $avail) { 459 if ($SLOT_QUEUE[$_][0] <= $avail) {
460 $busy = 0;
414 my $job = splice @SLOT_QUEUE, $_, 1, (); 461 my $job = splice @SLOT_QUEUE, $_, 1, ();
415 $job->[2]->send; 462 $job->[2]->send;
416 Coro::cede; 463 Coro::cede;
417 goto next_job; 464 goto next_job;
418 } 465 } else {
466 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
419 } 467 }
420 } 468 }
421 469
422 if (@SLOT_QUEUE) { 470 if (@SLOT_QUEUE) {
423 # we do not use wait_for_tick() as it returns immediately when tick is inactive 471 # we do not use wait_for_tick() as it returns immediately when tick is inactive
424 push @cf::WAIT_FOR_TICK, $signal; 472 push @cf::WAIT_FOR_TICK, $signal;
425 $signal->wait; 473 $signal->wait;
426 } else { 474 } else {
475 $busy = 0;
427 Coro::schedule; 476 Coro::schedule;
428 } 477 }
429 } 478 }
430}; 479};
431 480
432sub get_slot($;$$) { 481sub get_slot($;$$) {
433 return if tick_inhibit || $Coro::current == $Coro::main; 482 return if tick_inhibit || $Coro::current == $Coro::main;
434 483
435 my ($time, $pri, $name) = @_; 484 my ($time, $pri, $name) = @_;
436 485
437 $time = $TICK * .6 if $time > $TICK * .6; 486 $time = clamp $time, 0.01, $TICK * .6;
487
438 my $sig = new Coro::Signal; 488 my $sig = new Coro::Signal;
439 489
440 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 490 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
441 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 491 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
442 $SLOT_QUEUE->ready; 492 $SLOT_QUEUE->ready;
… …
468=cut 518=cut
469 519
470sub sync_job(&) { 520sub sync_job(&) {
471 my ($job) = @_; 521 my ($job) = @_;
472 522
473 if ($Coro::current == $Coro::main) { 523 if (in_main) {
474 my $time = EV::time; 524 my $time = AE::time;
475 525
476 # this is the main coro, too bad, we have to block 526 # this is the main coro, too bad, we have to block
477 # till the operation succeeds, freezing the server :/ 527 # till the operation succeeds, freezing the server :/
478 528
479 LOG llevError, Carp::longmess "sync job";#d# 529 #LOG llevError, Carp::longmess "sync job";#d#
480 530
481 my $freeze_guard = freeze_mainloop; 531 my $freeze_guard = freeze_mainloop;
482 532
483 my $busy = 1; 533 my $busy = 1;
484 my @res; 534 my @res;
485 535
486 (async { 536 (async {
487 $Coro::current->desc ("sync job coro"); 537 $Coro::current->desc ("sync job coro");
488 @res = eval { $job->() }; 538 @res = eval { $job->() };
489 warn $@ if $@; 539 error $@ if $@;
490 undef $busy; 540 undef $busy;
491 })->prio (Coro::PRIO_MAX); 541 })->prio (Coro::PRIO_MAX);
492 542
493 while ($busy) { 543 while ($busy) {
494 if (Coro::nready) { 544 if (Coro::nready) {
… …
496 } else { 546 } else {
497 EV::loop EV::LOOP_ONESHOT; 547 EV::loop EV::LOOP_ONESHOT;
498 } 548 }
499 } 549 }
500 550
501 my $time = EV::time - $time; 551 my $time = AE::time - $time;
502 552
503 $TICK_START += $time; # do not account sync jobs to server load 553 $TICK_START += $time; # do not account sync jobs to server load
504 554
505 wantarray ? @res : $res[0] 555 wantarray ? @res : $res[0]
506 } else { 556 } else {
… …
550 reset_signals; 600 reset_signals;
551 &$cb 601 &$cb
552 }, @args; 602 }, @args;
553 603
554 wantarray ? @res : $res[-1] 604 wantarray ? @res : $res[-1]
605}
606
607sub objinfo {
608 (
609 "counter value" => cf::object::object_count,
610 "objects created" => cf::object::create_count,
611 "objects destroyed" => cf::object::destroy_count,
612 "freelist size" => cf::object::free_count,
613 "allocated objects" => cf::object::objects_size,
614 "active objects" => cf::object::actives_size,
615 )
555} 616}
556 617
557=item $coin = coin_from_name $name 618=item $coin = coin_from_name $name
558 619
559=cut 620=cut
… …
596within each server. 657within each server.
597 658
598=cut 659=cut
599 660
600sub db_table($) { 661sub db_table($) {
662 cf::error "db_get called from main context"
663 if $Coro::current == $Coro::main;
664
601 my ($name) = @_; 665 my ($name) = @_;
602 my $db = BDB::db_create $DB_ENV; 666 my $db = BDB::db_create $DB_ENV;
603 667
604 eval { 668 eval {
605 $db->set_flags (BDB::CHKSUM); 669 $db->set_flags (BDB::CHKSUM);
… …
615} 679}
616 680
617our $DB; 681our $DB;
618 682
619sub db_init { 683sub db_init {
620 cf::sync_job {
621 $DB ||= db_table "db"; 684 $DB ||= db_table "db";
622 };
623} 685}
624 686
625sub db_get($$) { 687sub db_get($$) {
626 my $key = "$_[0]/$_[1]"; 688 my $key = "$_[0]/$_[1]";
627 689
628 cf::sync_job { 690 cf::error "db_get called from main context"
691 if $Coro::current == $Coro::main;
692
629 BDB::db_get $DB, undef, $key, my $data; 693 BDB::db_get $DB, undef, $key, my $data;
630 694
631 $! ? () 695 $! ? ()
632 : $data 696 : $data
633 }
634} 697}
635 698
636sub db_put($$$) { 699sub db_put($$$) {
637 BDB::dbreq_pri 4; 700 BDB::dbreq_pri 4;
638 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 701 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
694 757
695 my $t1 = Time::HiRes::time; 758 my $t1 = Time::HiRes::time;
696 my $data = $process->(\@data); 759 my $data = $process->(\@data);
697 my $t2 = Time::HiRes::time; 760 my $t2 = Time::HiRes::time;
698 761
699 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 762 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
700 763
701 db_put cache => "$id/data", $data; 764 db_put cache => "$id/data", $data;
702 db_put cache => "$id/md5" , $md5; 765 db_put cache => "$id/md5" , $md5;
703 db_put cache => "$id/meta", $meta; 766 db_put cache => "$id/meta", $meta;
704 767
… …
714 777
715=cut 778=cut
716 779
717sub datalog($@) { 780sub datalog($@) {
718 my ($type, %kv) = @_; 781 my ($type, %kv) = @_;
719 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 782 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
720} 783}
721 784
722=back 785=back
723 786
724=cut 787=cut
725 788
726############################################################################# 789#############################################################################
727 790
728=head2 ATTACHABLE OBJECTS 791=head2 ATTACHABLE OBJECTS
729 792
730Many objects in crossfire are so-called attachable objects. That means you can 793Many objects in deliantra are so-called attachable objects. That means you can
731attach callbacks/event handlers (a collection of which is called an "attachment") 794attach callbacks/event handlers (a collection of which is called an "attachment")
732to it. All such attachable objects support the following methods. 795to it. All such attachable objects support the following methods.
733 796
734In the following description, CLASS can be any of C<global>, C<object> 797In the following description, CLASS can be any of C<global>, C<object>
735C<player>, C<client> or C<map> (i.e. the attachable objects in 798C<player>, C<client> or C<map> (i.e. the attachable objects in
… …
785=item cf::CLASS::attachment $name, ... 848=item cf::CLASS::attachment $name, ...
786 849
787Register an attachment by C<$name> through which attachable objects of the 850Register an attachment by C<$name> through which attachable objects of the
788given CLASS can refer to this attachment. 851given CLASS can refer to this attachment.
789 852
790Some classes such as crossfire maps and objects can specify attachments 853Some classes such as deliantra maps and objects can specify attachments
791that are attached at load/instantiate time, thus the need for a name. 854that are attached at load/instantiate time, thus the need for a name.
792 855
793These calls expect any number of the following handler/hook descriptions: 856These calls expect any number of the following handler/hook descriptions:
794 857
795=over 4 858=over 4
… …
919 982
920 } elsif (exists $cb_id{$type}) { 983 } elsif (exists $cb_id{$type}) {
921 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 984 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
922 985
923 } elsif (ref $type) { 986 } elsif (ref $type) {
924 warn "attaching objects not supported, ignoring.\n"; 987 error "attaching objects not supported, ignoring.\n";
925 988
926 } else { 989 } else {
927 shift @arg; 990 shift @arg;
928 warn "attach argument '$type' not supported, ignoring.\n"; 991 error "attach argument '$type' not supported, ignoring.\n";
929 } 992 }
930 } 993 }
931} 994}
932 995
933sub _object_attach { 996sub _object_attach {
… …
943 _attach $registry, $klass, @attach; 1006 _attach $registry, $klass, @attach;
944 } 1007 }
945 1008
946 $obj->{$name} = \%arg; 1009 $obj->{$name} = \%arg;
947 } else { 1010 } else {
948 warn "object uses attachment '$name' which is not available, postponing.\n"; 1011 info "object uses attachment '$name' which is not available, postponing.\n";
949 } 1012 }
950 1013
951 $obj->{_attachment}{$name} = undef; 1014 $obj->{_attachment}{$name} = undef;
952} 1015}
953 1016
… …
1012 1075
1013 for (@$callbacks) { 1076 for (@$callbacks) {
1014 eval { &{$_->[1]} }; 1077 eval { &{$_->[1]} };
1015 1078
1016 if ($@) { 1079 if ($@) {
1017 warn "$@";
1018 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1080 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1019 override; 1081 override;
1020 } 1082 }
1021 1083
1022 return 1 if $override; 1084 return 1 if $override;
1023 } 1085 }
… …
1086 1148
1087sub reattach { 1149sub reattach {
1088 # basically do the same as instantiate, without calling instantiate 1150 # basically do the same as instantiate, without calling instantiate
1089 my ($obj) = @_; 1151 my ($obj) = @_;
1090 1152
1153 # no longer needed after getting rid of delete_package?
1091 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1154 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1092 1155
1093 my $registry = $obj->registry; 1156 my $registry = $obj->registry;
1094 1157
1095 @$registry = (); 1158 @$registry = ();
1096 1159
… …
1101 for (@$attach) { 1164 for (@$attach) {
1102 my ($klass, @attach) = @$_; 1165 my ($klass, @attach) = @$_;
1103 _attach $registry, $klass, @attach; 1166 _attach $registry, $klass, @attach;
1104 } 1167 }
1105 } else { 1168 } else {
1106 warn "object uses attachment '$name' that is not available, postponing.\n"; 1169 info "object uses attachment '$name' that is not available, postponing.\n";
1107 } 1170 }
1108 } 1171 }
1109} 1172}
1110 1173
1111cf::attachable->attach ( 1174cf::attachable->attach (
… …
1138 my ($filename, $rdata, $objs) = @_; 1201 my ($filename, $rdata, $objs) = @_;
1139 1202
1140 sync_job { 1203 sync_job {
1141 if (length $$rdata) { 1204 if (length $$rdata) {
1142 utf8::decode (my $decname = $filename); 1205 utf8::decode (my $decname = $filename);
1143 warn sprintf "saving %s (%d,%d)\n", 1206 trace sprintf "saving %s (%d,%d)\n",
1144 $decname, length $$rdata, scalar @$objs; 1207 $decname, length $$rdata, scalar @$objs
1208 if $VERBOSE_IO;
1145 1209
1146 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1210 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1147 aio_chmod $fh, SAVE_MODE; 1211 aio_chmod $fh, SAVE_MODE;
1148 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1212 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1149 aio_fsync $fh if $cf::USE_FSYNC; 1213 if ($cf::USE_FSYNC) {
1214 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1215 aio_fsync $fh;
1216 }
1150 aio_close $fh; 1217 aio_close $fh;
1151 1218
1152 if (@$objs) { 1219 if (@$objs) {
1153 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1220 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1154 aio_chmod $fh, SAVE_MODE; 1221 aio_chmod $fh, SAVE_MODE;
1155 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1222 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1156 aio_write $fh, 0, (length $data), $data, 0; 1223 aio_write $fh, 0, (length $data), $data, 0;
1157 aio_fsync $fh if $cf::USE_FSYNC; 1224 if ($cf::USE_FSYNC) {
1225 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;
1226 aio_fsync $fh;
1227 }
1158 aio_close $fh; 1228 aio_close $fh;
1159 aio_rename "$filename.pst~", "$filename.pst"; 1229 aio_rename "$filename.pst~", "$filename.pst";
1160 } 1230 }
1161 } else { 1231 } else {
1162 aio_unlink "$filename.pst"; 1232 aio_unlink "$filename.pst";
1163 } 1233 }
1164 1234
1165 aio_rename "$filename~", $filename; 1235 aio_rename "$filename~", $filename;
1236
1237 $filename =~ s%/[^/]+$%%;
1238 aio_pathsync $filename if $cf::USE_FSYNC;
1166 } else { 1239 } else {
1167 warn "FATAL: $filename~: $!\n"; 1240 error "unable to save objects: $filename~: $!\n";
1168 } 1241 }
1169 } else { 1242 } else {
1170 aio_unlink $filename; 1243 aio_unlink $filename;
1171 aio_unlink "$filename.pst"; 1244 aio_unlink "$filename.pst";
1172 } 1245 }
… …
1196 my $st = eval { Coro::Storable::thaw $av }; 1269 my $st = eval { Coro::Storable::thaw $av };
1197 $av = $st->{objs}; 1270 $av = $st->{objs};
1198 } 1271 }
1199 1272
1200 utf8::decode (my $decname = $filename); 1273 utf8::decode (my $decname = $filename);
1201 warn sprintf "loading %s (%d,%d)\n", 1274 trace sprintf "loading %s (%d,%d)\n",
1202 $decname, length $data, scalar @{$av || []}; 1275 $decname, length $data, scalar @{$av || []}
1276 if $VERBOSE_IO;
1203 1277
1204 ($data, $av) 1278 ($data, $av)
1205} 1279}
1206 1280
1207=head2 COMMAND CALLBACKS 1281=head2 COMMAND CALLBACKS
… …
1263 my ($name, $cb) = @_; 1337 my ($name, $cb) = @_;
1264 1338
1265 $EXTICMD{$name} = $cb; 1339 $EXTICMD{$name} = $cb;
1266} 1340}
1267 1341
1342use File::Glob ();
1343
1268cf::player->attach ( 1344cf::player->attach (
1269 on_command => sub { 1345 on_unknown_command => sub {
1270 my ($pl, $name, $params) = @_; 1346 my ($pl, $name, $params) = @_;
1271 1347
1272 my $cb = $COMMAND{$name} 1348 my $cb = $COMMAND{$name}
1273 or return; 1349 or return;
1274 1350
… …
1297 1373
1298 $pl->ext_reply ($reply, @reply) 1374 $pl->ext_reply ($reply, @reply)
1299 if $reply; 1375 if $reply;
1300 1376
1301 } else { 1377 } else {
1302 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1378 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1303 } 1379 }
1304 1380
1305 cf::override; 1381 cf::override;
1306 }, 1382 },
1307); 1383);
1308 1384
1385# "readahead" all extensions
1386sub cache_extensions {
1387 my $grp = IO::AIO::aio_group;
1388
1389 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1390 for (grep /\.ext$/, @{$_[0]}) {
1391 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1392 }
1393 };
1394
1395 $grp
1396}
1397
1309sub load_extensions { 1398sub load_extensions {
1399 info "loading extensions...";
1400
1310 cf::sync_job { 1401 cf::sync_job {
1311 my %todo; 1402 my %todo;
1312 1403
1313 for my $path (<$LIBDIR/*.ext>) { 1404 for my $path (<$LIBDIR/*.ext>) {
1314 next unless -r $path; 1405 next unless -r $path;
… …
1332 1423
1333 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1424 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1334 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1425 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1335 1426
1336 $ext{source} = 1427 $ext{source} =
1337 "package $pkg; use strict; use utf8;\n" 1428 "package $pkg; use common::sense;\n"
1338 . "#line 1 \"$path\"\n{\n" 1429 . "#line 1 \"$path\"\n{\n"
1339 . $source 1430 . $source
1340 . "\n};\n1"; 1431 . "\n};\n1";
1341 1432
1342 $todo{$base} = \%ext; 1433 $todo{$base} = \%ext;
1343 } 1434 }
1344 1435
1436 my $pass = 0;
1345 my %done; 1437 my %done;
1346 while (%todo) { 1438 while (%todo) {
1347 my $progress; 1439 my $progress;
1348 1440
1441 ++$pass;
1442
1443 ext:
1349 while (my ($k, $v) = each %todo) { 1444 while (my ($k, $v) = each %todo) {
1350 for (split /,\s*/, $v->{meta}{depends}) { 1445 for (split /,\s*/, $v->{meta}{depends}) {
1351 goto skip 1446 next ext
1352 unless exists $done{$_}; 1447 unless exists $done{$_};
1353 } 1448 }
1354 1449
1355 warn "... loading '$k' into '$v->{pkg}'\n"; 1450 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1356 1451
1357 unless (eval $v->{source}) { 1452 my $active = eval $v->{source};
1453
1454 if (length $@) {
1358 my $msg = $@ ? "$v->{path}: $@\n" 1455 error "$v->{path}: $@\n";
1359 : "$v->{base}: extension inactive.\n"; 1456 undef $@; # work around perl 5.10.0 utf-8 caching bug
1360 1457
1361 if (exists $v->{meta}{mandatory}) {
1362 warn $msg;
1363 cf::cleanup "mandatory extension failed to load, exiting."; 1458 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1364 } 1459 if exists $v->{meta}{mandatory};
1365 1460
1366 warn $msg; 1461 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1462 delete $todo{$k};
1463 } else {
1464 $done{$k} = delete $todo{$k};
1465 push @EXTS, $v->{pkg};
1466 $progress = 1;
1467
1468 info "$v->{base}: extension inactive.\n"
1469 unless $active;
1367 } 1470 }
1368
1369 $done{$k} = delete $todo{$k};
1370 push @EXTS, $v->{pkg};
1371 $progress = 1;
1372 } 1471 }
1373 1472
1374 skip: 1473 unless ($progress) {
1375 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1474 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1376 unless $progress; 1475
1476 while (my ($k, $v) = each %todo) {
1477 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1478 if exists $v->{meta}{mandatory};
1479 }
1480 }
1377 } 1481 }
1378 }; 1482 };
1379} 1483}
1380 1484
1381############################################################################# 1485#############################################################################
1382 1486
1383=back 1487=back
1384 1488
1385=head2 CORE EXTENSIONS 1489=head2 CORE EXTENSIONS
1386 1490
1387Functions and methods that extend core crossfire objects. 1491Functions and methods that extend core deliantra objects.
1388 1492
1389=cut 1493=cut
1390 1494
1391package cf::player; 1495package cf::player;
1392 1496
… …
1435 1539
1436sub exists($) { 1540sub exists($) {
1437 my ($login) = @_; 1541 my ($login) = @_;
1438 1542
1439 $cf::PLAYER{$login} 1543 $cf::PLAYER{$login}
1440 or cf::sync_job { !aio_stat path $login } 1544 or !aio_stat path $login
1441} 1545}
1442 1546
1443sub find($) { 1547sub find($) {
1444 return $cf::PLAYER{$_[0]} || do { 1548 return $cf::PLAYER{$_[0]} || do {
1445 my $login = $_[0]; 1549 my $login = $_[0];
… …
1465 $cf::PLAYER{$login} = $pl 1569 $cf::PLAYER{$login} = $pl
1466 } 1570 }
1467 } 1571 }
1468} 1572}
1469 1573
1574cf::player->attach (
1575 on_load => sub {
1576 my ($pl, $path) = @_;
1577
1578 # restore slots saved in save, below
1579 my $slots = delete $pl->{_slots};
1580
1581 $pl->ob->current_weapon ($slots->[0]);
1582 $pl->combat_ob ($slots->[1]);
1583 $pl->ranged_ob ($slots->[2]);
1584 },
1585);
1586
1470sub save($) { 1587sub save($) {
1471 my ($pl) = @_; 1588 my ($pl) = @_;
1472 1589
1473 return if $pl->{deny_save}; 1590 return if $pl->{deny_save};
1474 1591
… …
1479 1596
1480 aio_mkdir playerdir $pl, 0770; 1597 aio_mkdir playerdir $pl, 0770;
1481 $pl->{last_save} = $cf::RUNTIME; 1598 $pl->{last_save} = $cf::RUNTIME;
1482 1599
1483 cf::get_slot 0.01; 1600 cf::get_slot 0.01;
1601
1602 # save slots, to be restored later
1603 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1484 1604
1485 $pl->save_pl ($path); 1605 $pl->save_pl ($path);
1486 cf::cede_to_tick; 1606 cf::cede_to_tick;
1487} 1607}
1488 1608
… …
1520 my ($pl) = @_; 1640 my ($pl) = @_;
1521 1641
1522 my $name = $pl->ob->name; 1642 my $name = $pl->ob->name;
1523 1643
1524 $pl->{deny_save} = 1; 1644 $pl->{deny_save} = 1;
1525 $pl->password ("*"); # this should lock out the player until we nuked the dir 1645 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1526 1646
1527 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1647 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1528 $pl->deactivate; 1648 $pl->deactivate;
1529 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1649 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1530 $pl->ob->check_score;
1531 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1650 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1532 $pl->ns->destroy if $pl->ns; 1651 $pl->ns->destroy if $pl->ns;
1533 1652
1534 my $path = playerdir $pl; 1653 my $path = playerdir $pl;
1535 my $temp = "$path~$cf::RUNTIME~deleting~"; 1654 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1590 \@logins 1709 \@logins
1591} 1710}
1592 1711
1593=item $player->maps 1712=item $player->maps
1594 1713
1714=item cf::player::maps $login
1715
1595Returns an arrayref of map paths that are private for this 1716Returns an arrayref of map paths that are private for this
1596player. May block. 1717player. May block.
1597 1718
1598=cut 1719=cut
1599 1720
… …
1616 } 1737 }
1617 1738
1618 \@paths 1739 \@paths
1619} 1740}
1620 1741
1621=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1742=item $protocol_xml = $player->expand_cfpod ($cfpod)
1622 1743
1623Expand crossfire pod fragments into protocol xml. 1744Expand deliantra pod fragments into protocol xml.
1624
1625=cut
1626
1627use re 'eval';
1628
1629my $group;
1630my $interior; $interior = qr{
1631 # match a pod interior sequence sans C<< >>
1632 (?:
1633 \ (.*?)\ (?{ $group = $^N })
1634 | < (??{$interior}) >
1635 )
1636}x;
1637
1638sub expand_cfpod {
1639 my ($self, $pod) = @_;
1640
1641 my $xml;
1642
1643 while () {
1644 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1645 $group = $1;
1646
1647 $group =~ s/&/&amp;/g;
1648 $group =~ s/</&lt;/g;
1649
1650 $xml .= $group;
1651 } elsif ($pod =~ m%\G
1652 ([BCGHITU])
1653 <
1654 (?:
1655 ([^<>]*) (?{ $group = $^N })
1656 | < $interior >
1657 )
1658 >
1659 %gcsx
1660 ) {
1661 my ($code, $data) = ($1, $group);
1662
1663 if ($code eq "B") {
1664 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1665 } elsif ($code eq "I") {
1666 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1667 } elsif ($code eq "U") {
1668 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1669 } elsif ($code eq "C") {
1670 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1671 } elsif ($code eq "T") {
1672 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1673 } elsif ($code eq "G") {
1674 my ($male, $female) = split /\|/, $data;
1675 $data = $self->gender ? $female : $male;
1676 $xml .= expand_cfpod ($self, $data);
1677 } elsif ($code eq "H") {
1678 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1679 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1680 "")
1681 [$self->{hintmode}];
1682 } else {
1683 $xml .= "error processing '$code($data)' directive";
1684 }
1685 } else {
1686 if ($pod =~ /\G(.+)/) {
1687 warn "parse error while expanding $pod (at $1)";
1688 }
1689 last;
1690 }
1691 }
1692
1693 for ($xml) {
1694 # create single paragraphs (very hackish)
1695 s/(?<=\S)\n(?=\w)/ /g;
1696
1697 # compress some whitespace
1698 s/\s+\n/\n/g; # ws line-ends
1699 s/\n\n+/\n/g; # double lines
1700 s/^\n+//; # beginning lines
1701 s/\n+$//; # ending lines
1702 }
1703
1704 $xml
1705}
1706
1707no re 'eval';
1708
1709sub hintmode {
1710 $_[0]{hintmode} = $_[1] if @_ > 1;
1711 $_[0]{hintmode}
1712}
1713 1745
1714=item $player->ext_reply ($msgid, @msg) 1746=item $player->ext_reply ($msgid, @msg)
1715 1747
1716Sends an ext reply to the player. 1748Sends an ext reply to the player.
1717 1749
… …
1749 1781
1750=cut 1782=cut
1751 1783
1752sub find_by_path($) { 1784sub find_by_path($) {
1753 my ($path) = @_; 1785 my ($path) = @_;
1786
1787 $path =~ s/^~[^\/]*//; # skip ~login
1754 1788
1755 my ($match, $specificity); 1789 my ($match, $specificity);
1756 1790
1757 for my $region (list) { 1791 for my $region (list) {
1758 if ($region->{match} && $path =~ $region->{match}) { 1792 if ($region->{match} && $path =~ $region->{match}) {
… …
1790 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1824 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1791 1825
1792 # mit "rum" bekleckern, nicht 1826 # mit "rum" bekleckern, nicht
1793 $self->_create_random_map ( 1827 $self->_create_random_map (
1794 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1828 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1795 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1829 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1796 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1830 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1797 $rmp->{exit_on_final_map}, 1831 $rmp->{exit_on_final_map},
1798 $rmp->{xsize}, $rmp->{ysize}, 1832 $rmp->{xsize}, $rmp->{ysize},
1799 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1833 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1800 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1834 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1815 1849
1816sub register { 1850sub register {
1817 my (undef, $regex, $prio) = @_; 1851 my (undef, $regex, $prio) = @_;
1818 my $pkg = caller; 1852 my $pkg = caller;
1819 1853
1820 no strict;
1821 push @{"$pkg\::ISA"}, __PACKAGE__; 1854 push @{"$pkg\::ISA"}, __PACKAGE__;
1822 1855
1823 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1856 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1824} 1857}
1825 1858
1826# also paths starting with '/' 1859# also paths starting with '/'
1827$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1860$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1828 1861
1829sub thawer_merge { 1862sub thawer_merge {
1830 my ($self, $merge) = @_; 1863 my ($self, $merge) = @_;
1831 1864
1832 # we have to keep some variables in memory intact 1865 # we have to keep some variables in memory intact
… …
1930 1963
1931 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1964 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1932 "$UNIQUEDIR/$path" 1965 "$UNIQUEDIR/$path"
1933} 1966}
1934 1967
1935# and all this just because we cannot iterate over
1936# all maps in C++...
1937sub change_all_map_light {
1938 my ($change) = @_;
1939
1940 $_->change_map_light ($change)
1941 for grep $_->outdoor, values %cf::MAP;
1942}
1943
1944sub decay_objects { 1968sub decay_objects {
1945 my ($self) = @_; 1969 my ($self) = @_;
1946 1970
1947 return if $self->{deny_reset}; 1971 return if $self->{deny_reset};
1948 1972
… …
2030sub find { 2054sub find {
2031 my ($path, $origin) = @_; 2055 my ($path, $origin) = @_;
2032 2056
2033 $path = normalise $path, $origin && $origin->path; 2057 $path = normalise $path, $origin && $origin->path;
2034 2058
2035 cf::lock_wait "map_data:$path";#d#remove 2059 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2036 cf::lock_wait "map_find:$path"; 2060 my $guard2 = cf::lock_acquire "map_find:$path";
2037 2061
2038 $cf::MAP{$path} || do { 2062 $cf::MAP{$path} || do {
2039 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2040 my $guard2 = cf::lock_acquire "map_find:$path";
2041
2042 my $map = new_from_path cf::map $path 2063 my $map = new_from_path cf::map $path
2043 or return; 2064 or return;
2044 2065
2045 $map->{last_save} = $cf::RUNTIME; 2066 $map->{last_save} = $cf::RUNTIME;
2046 2067
… …
2058 2079
2059 $cf::MAP{$path} = $map 2080 $cf::MAP{$path} = $map
2060 } 2081 }
2061} 2082}
2062 2083
2063sub pre_load { } 2084sub pre_load { }
2064sub post_load { } 2085#sub post_load { } # XS
2065 2086
2066sub load { 2087sub load {
2067 my ($self) = @_; 2088 my ($self) = @_;
2068 2089
2069 local $self->{deny_reset} = 1; # loading can take a long time 2090 local $self->{deny_reset} = 1; # loading can take a long time
… …
2086 my $f = new_from_file cf::object::thawer $self->{load_path}; 2107 my $f = new_from_file cf::object::thawer $self->{load_path};
2087 $f->skip_block; 2108 $f->skip_block;
2088 $self->_load_objects ($f) 2109 $self->_load_objects ($f)
2089 or return; 2110 or return;
2090 2111
2091 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2112 $self->post_load_original
2092 if delete $self->{load_original}; 2113 if delete $self->{load_original};
2093 2114
2094 if (my $uniq = $self->uniq_path) { 2115 if (my $uniq = $self->uniq_path) {
2095 utf8::encode $uniq; 2116 utf8::encode $uniq;
2096 unless (aio_stat $uniq) { 2117 unless (aio_stat $uniq) {
… …
2114 unless ($self->{deny_activate}) { 2135 unless ($self->{deny_activate}) {
2115 $self->decay_objects; 2136 $self->decay_objects;
2116 $self->fix_auto_apply; 2137 $self->fix_auto_apply;
2117 $self->update_buttons; 2138 $self->update_buttons;
2118 cf::cede_to_tick; 2139 cf::cede_to_tick;
2119 $self->set_darkness_map;
2120 cf::cede_to_tick;
2121 $self->activate; 2140 $self->activate;
2122 } 2141 }
2123 2142
2124 $self->{last_save} = $cf::RUNTIME; 2143 $self->{last_save} = $cf::RUNTIME;
2125 $self->last_access ($cf::RUNTIME); 2144 $self->last_access ($cf::RUNTIME);
… …
2128 } 2147 }
2129 2148
2130 $self->post_load; 2149 $self->post_load;
2131} 2150}
2132 2151
2152# customize the map for a given player, i.e.
2153# return the _real_ map. used by e.g. per-player
2154# maps to change the path to ~playername/mappath
2133sub customise_for { 2155sub customise_for {
2134 my ($self, $ob) = @_; 2156 my ($self, $ob) = @_;
2135 2157
2136 return find "~" . $ob->name . "/" . $self->{path} 2158 return find "~" . $ob->name . "/" . $self->{path}
2137 if $self->per_player; 2159 if $self->per_player;
… …
2153 or next; 2175 or next;
2154 $neigh = find $neigh, $map 2176 $neigh = find $neigh, $map
2155 or next; 2177 or next;
2156 $neigh->load; 2178 $neigh->load;
2157 2179
2180 # now find the diagonal neighbours
2158 push @neigh, 2181 push @neigh,
2159 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2182 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2160 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2183 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2161 } 2184 }
2162 2185
… …
2169} 2192}
2170 2193
2171sub find_sync { 2194sub find_sync {
2172 my ($path, $origin) = @_; 2195 my ($path, $origin) = @_;
2173 2196
2174 cf::sync_job { find $path, $origin } 2197 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2198 if $Coro::current == $Coro::main;
2199
2200 find $path, $origin
2175} 2201}
2176 2202
2177sub do_load_sync { 2203sub do_load_sync {
2178 my ($map) = @_; 2204 my ($map) = @_;
2179 2205
2180 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2206 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2181 if $Coro::current == $Coro::main; 2207 if $Coro::current == $Coro::main;
2182 2208
2183 cf::sync_job { $map->load }; 2209 $map->load;
2184} 2210}
2185 2211
2186our %MAP_PREFETCH; 2212our %MAP_PREFETCH;
2187our $MAP_PREFETCHER = undef; 2213our $MAP_PREFETCHER = undef;
2188 2214
… …
2214 $MAP_PREFETCHER->prio (6); 2240 $MAP_PREFETCHER->prio (6);
2215 2241
2216 () 2242 ()
2217} 2243}
2218 2244
2245# common code, used by both ->save and ->swapout
2219sub save { 2246sub _save {
2220 my ($self) = @_; 2247 my ($self) = @_;
2221
2222 my $lock = cf::lock_acquire "map_data:$self->{path}";
2223 2248
2224 $self->{last_save} = $cf::RUNTIME; 2249 $self->{last_save} = $cf::RUNTIME;
2225 2250
2226 return unless $self->dirty; 2251 return unless $self->dirty;
2227 2252
… …
2247 } else { 2272 } else {
2248 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2273 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2249 } 2274 }
2250} 2275}
2251 2276
2277sub save {
2278 my ($self) = @_;
2279
2280 my $lock = cf::lock_acquire "map_data:$self->{path}";
2281
2282 $self->_save;
2283}
2284
2252sub swap_out { 2285sub swap_out {
2253 my ($self) = @_; 2286 my ($self) = @_;
2254 2287
2255 # save first because save cedes
2256 $self->save;
2257
2258 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2288 my $lock = cf::lock_acquire "map_data:$self->{path}";
2259 2289
2260 return if $self->players;
2261 return if $self->in_memory != cf::MAP_ACTIVE; 2290 return if $self->in_memory != cf::MAP_ACTIVE;
2262 return if $self->{deny_save}; 2291 return if $self->{deny_save};
2292 return if $self->players;
2263 2293
2294 # first deactivate the map and "unlink" it from the core
2295 $self->deactivate;
2296 $_->clear_links_to ($self) for values %cf::MAP;
2264 $self->in_memory (cf::MAP_SWAPPED); 2297 $self->in_memory (cf::MAP_SWAPPED);
2298
2299 # then atomically save
2300 $self->_save;
2301
2302 # then free the map
2303 $self->clear;
2304}
2305
2306sub reset_at {
2307 my ($self) = @_;
2308
2309 # TODO: safety, remove and allow resettable per-player maps
2310 return 1e99 if $self->{deny_reset};
2311
2312 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2313 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2314
2315 $time + $to
2316}
2317
2318sub should_reset {
2319 my ($self) = @_;
2320
2321 $self->reset_at <= $cf::RUNTIME
2322}
2323
2324sub reset {
2325 my ($self) = @_;
2326
2327 my $lock = cf::lock_acquire "map_data:$self->{path}";
2328
2329 return if $self->players;
2330
2331 cf::trace "resetting map ", $self->path, "\n";
2332
2333 $self->in_memory (cf::MAP_SWAPPED);
2334
2335 # need to save uniques path
2336 unless ($self->{deny_save}) {
2337 my $uniq = $self->uniq_path; utf8::encode $uniq;
2338
2339 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2340 if $uniq;
2341 }
2342
2343 delete $cf::MAP{$self->path};
2265 2344
2266 $self->deactivate; 2345 $self->deactivate;
2267 $_->clear_links_to ($self) for values %cf::MAP; 2346 $_->clear_links_to ($self) for values %cf::MAP;
2268 $self->clear; 2347 $self->clear;
2269}
2270
2271sub reset_at {
2272 my ($self) = @_;
2273
2274 # TODO: safety, remove and allow resettable per-player maps
2275 return 1e99 if $self->{deny_reset};
2276
2277 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2278 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2279
2280 $time + $to
2281}
2282
2283sub should_reset {
2284 my ($self) = @_;
2285
2286 $self->reset_at <= $cf::RUNTIME
2287}
2288
2289sub reset {
2290 my ($self) = @_;
2291
2292 my $lock = cf::lock_acquire "map_data:$self->{path}";
2293
2294 return if $self->players;
2295
2296 warn "resetting map ", $self->path;
2297
2298 $self->in_memory (cf::MAP_SWAPPED);
2299
2300 # need to save uniques path
2301 unless ($self->{deny_save}) {
2302 my $uniq = $self->uniq_path; utf8::encode $uniq;
2303
2304 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2305 if $uniq;
2306 }
2307
2308 delete $cf::MAP{$self->path};
2309
2310 $self->deactivate;
2311 $_->clear_links_to ($self) for values %cf::MAP;
2312 $self->clear;
2313 2348
2314 $self->unlink_save; 2349 $self->unlink_save;
2315 $self->destroy; 2350 $self->destroy;
2316} 2351}
2317 2352
… …
2325 2360
2326 delete $cf::MAP{$self->path}; 2361 delete $cf::MAP{$self->path};
2327 2362
2328 $self->unlink_save; 2363 $self->unlink_save;
2329 2364
2330 bless $self, "cf::map"; 2365 bless $self, "cf::map::wrap";
2331 delete $self->{deny_reset}; 2366 delete $self->{deny_reset};
2332 $self->{deny_save} = 1; 2367 $self->{deny_save} = 1;
2333 $self->reset_timeout (1); 2368 $self->reset_timeout (1);
2334 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2369 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2335 2370
… …
2392 : normalise $_ 2427 : normalise $_
2393 } @{ aio_readdir $UNIQUEDIR or [] } 2428 } @{ aio_readdir $UNIQUEDIR or [] }
2394 ] 2429 ]
2395} 2430}
2396 2431
2432=item cf::map::static_maps
2433
2434Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2435file in the shared directory excluding F</styles> and F</editor>). May
2436block.
2437
2438=cut
2439
2440sub static_maps() {
2441 my @dirs = "";
2442 my @maps;
2443
2444 while (@dirs) {
2445 my $dir = shift @dirs;
2446
2447 next if $dir eq "/styles" || $dir eq "/editor";
2448
2449 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2450 or return;
2451
2452 for (@$files) {
2453 s/\.map$// or next;
2454 utf8::decode $_;
2455 push @maps, "$dir/$_";
2456 }
2457
2458 push @dirs, map "$dir/$_", @$dirs;
2459 }
2460
2461 \@maps
2462}
2463
2397=back 2464=back
2398 2465
2399=head3 cf::object 2466=head3 cf::object
2400 2467
2401=cut 2468=cut
… …
2466 2533
2467our $SAY_CHANNEL = { 2534our $SAY_CHANNEL = {
2468 id => "say", 2535 id => "say",
2469 title => "Map", 2536 title => "Map",
2470 reply => "say ", 2537 reply => "say ",
2471 tooltip => "Things said to and replied from npcs near you and other players on the same map only.", 2538 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2472}; 2539};
2473 2540
2474our $CHAT_CHANNEL = { 2541our $CHAT_CHANNEL = {
2475 id => "chat", 2542 id => "chat",
2476 title => "Chat", 2543 title => "Chat",
… …
2531 2598
2532=item $player_object->enter_link 2599=item $player_object->enter_link
2533 2600
2534Freezes the player and moves him/her to a special map (C<{link}>). 2601Freezes the player and moves him/her to a special map (C<{link}>).
2535 2602
2536The player should be reasonably safe there for short amounts of time. You 2603The player should be reasonably safe there for short amounts of time (e.g.
2537I<MUST> call C<leave_link> as soon as possible, though. 2604for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2605though, as the player cannot control the character while it is on the link
2606map.
2538 2607
2539Will never block. 2608Will never block.
2540 2609
2541=item $player_object->leave_link ($map, $x, $y) 2610=item $player_object->leave_link ($map, $x, $y)
2542 2611
… …
2562sub cf::object::player::enter_link { 2631sub cf::object::player::enter_link {
2563 my ($self) = @_; 2632 my ($self) = @_;
2564 2633
2565 $self->deactivate_recursive; 2634 $self->deactivate_recursive;
2566 2635
2636 ++$self->{_link_recursion};
2637
2567 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2638 return if UNIVERSAL::isa $self->map, "ext::map_link";
2568 2639
2569 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2640 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2570 if $self->map && $self->map->{path} ne "{link}"; 2641 if $self->map && $self->map->{path} ne "{link}";
2571 2642
2572 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2643 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2573} 2644}
2574 2645
2575sub cf::object::player::leave_link { 2646sub cf::object::player::leave_link {
2576 my ($self, $map, $x, $y) = @_; 2647 my ($self, $map, $x, $y) = @_;
2577 2648
… …
2594 ($x, $y) = (-1, -1) 2665 ($x, $y) = (-1, -1)
2595 unless (defined $x) && (defined $y); 2666 unless (defined $x) && (defined $y);
2596 2667
2597 # use -1 or undef as default coordinates, not 0, 0 2668 # use -1 or undef as default coordinates, not 0, 0
2598 ($x, $y) = ($map->enter_x, $map->enter_y) 2669 ($x, $y) = ($map->enter_x, $map->enter_y)
2599 if $x <=0 && $y <= 0; 2670 if $x <= 0 && $y <= 0;
2600 2671
2601 $map->load; 2672 $map->load;
2602 $map->load_neighbours; 2673 $map->load_neighbours;
2603 2674
2604 return unless $self->contr->active; 2675 return unless $self->contr->active;
2605 $self->activate_recursive;
2606 2676
2607 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2677 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2608 $self->enter_map ($map, $x, $y); 2678 if ($self->enter_map ($map, $x, $y)) {
2609} 2679 # entering was successful
2680 delete $self->{_link_recursion};
2681 # only activate afterwards, to support waiting in hooks
2682 $self->activate_recursive;
2683 }
2610 2684
2685}
2686
2611=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2687=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2612 2688
2613Moves the player to the given map-path and coordinates by first freezing 2689Moves the player to the given map-path and coordinates by first freezing
2614her, loading and preparing them map, calling the provided $check callback 2690her, loading and preparing them map, calling the provided $check callback
2615that has to return the map if sucecssful, and then unfreezes the player on 2691that has to return the map if sucecssful, and then unfreezes the player on
2616the new (success) or old (failed) map position. In either case, $done will 2692the new (success) or old (failed) map position. In either case, $done will
2617be called at the end of this process. 2693be called at the end of this process.
2618 2694
2695Note that $check will be called with a potentially non-loaded map, so if
2696it needs a loaded map it has to call C<< ->load >>.
2697
2619=cut 2698=cut
2620 2699
2621our $GOTOGEN; 2700our $GOTOGEN;
2622 2701
2623sub cf::object::player::goto { 2702sub cf::object::player::goto {
2624 my ($self, $path, $x, $y, $check, $done) = @_; 2703 my ($self, $path, $x, $y, $check, $done) = @_;
2704
2705 if ($self->{_link_recursion} >= $MAX_LINKS) {
2706 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2707 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2708 ($path, $x, $y) = @$EMERGENCY_POSITION;
2709 }
2625 2710
2626 # do generation counting so two concurrent goto's will be executed in-order 2711 # do generation counting so two concurrent goto's will be executed in-order
2627 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2712 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2628 2713
2629 $self->enter_link; 2714 $self->enter_link;
… …
2653 my $map = eval { 2738 my $map = eval {
2654 my $map = defined $path ? cf::map::find $path : undef; 2739 my $map = defined $path ? cf::map::find $path : undef;
2655 2740
2656 if ($map) { 2741 if ($map) {
2657 $map = $map->customise_for ($self); 2742 $map = $map->customise_for ($self);
2658 $map = $check->($map) if $check && $map; 2743 $map = $check->($map, $x, $y, $self) if $check && $map;
2659 } else { 2744 } else {
2660 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2745 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2661 } 2746 }
2662 2747
2663 $map 2748 $map
… …
2671 if ($gen == $self->{_goto_generation}) { 2756 if ($gen == $self->{_goto_generation}) {
2672 delete $self->{_goto_generation}; 2757 delete $self->{_goto_generation};
2673 $self->leave_link ($map, $x, $y); 2758 $self->leave_link ($map, $x, $y);
2674 } 2759 }
2675 2760
2676 $done->() if $done; 2761 $done->($self) if $done;
2677 })->prio (1); 2762 })->prio (1);
2678} 2763}
2679 2764
2680=item $player_object->enter_exit ($exit_object) 2765=item $player_object->enter_exit ($exit_object)
2681 2766
… …
2769 $self->contr->savebed ($map, $x, $y) 2854 $self->contr->savebed ($map, $x, $y)
2770 if $exit->flag (cf::FLAG_DAMNED); 2855 if $exit->flag (cf::FLAG_DAMNED);
2771 2856
2772 1 2857 1
2773 }) { 2858 }) {
2774 $self->message ("Something went wrong deep within the crossfire server. " 2859 $self->message ("Something went wrong deep within the deliantra server. "
2775 . "I'll try to bring you back to the map you were before. " 2860 . "I'll try to bring you back to the map you were before. "
2776 . "Please report this to the dungeon master!", 2861 . "Please report this to the dungeon master!",
2777 cf::NDI_UNIQUE | cf::NDI_RED); 2862 cf::NDI_UNIQUE | cf::NDI_RED);
2778 2863
2779 warn "ERROR in enter_exit: $@"; 2864 error "ERROR in enter_exit: $@";
2780 $self->leave_link; 2865 $self->leave_link;
2781 } 2866 }
2782 })->prio (1); 2867 })->prio (1);
2783} 2868}
2784 2869
… …
2796sub cf::client::send_drawinfo { 2881sub cf::client::send_drawinfo {
2797 my ($self, $text, $flags) = @_; 2882 my ($self, $text, $flags) = @_;
2798 2883
2799 utf8::encode $text; 2884 utf8::encode $text;
2800 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2885 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2886}
2887
2888=item $client->send_big_packet ($pkt)
2889
2890Like C<send_packet>, but tries to compress large packets, and fragments
2891them as required.
2892
2893=cut
2894
2895our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2896
2897sub cf::client::send_big_packet {
2898 my ($self, $pkt) = @_;
2899
2900 # try lzf for large packets
2901 $pkt = "lzf " . Compress::LZF::compress $pkt
2902 if 1024 <= length $pkt and $self->{can_lzf};
2903
2904 # split very large packets
2905 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2906 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2907 $pkt = "frag";
2908 }
2909
2910 $self->send_packet ($pkt);
2801} 2911}
2802 2912
2803=item $client->send_msg ($channel, $msg, $color, [extra...]) 2913=item $client->send_msg ($channel, $msg, $color, [extra...])
2804 2914
2805Send a drawinfo or msg packet to the client, formatting the msg for the 2915Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2809 2919
2810=cut 2920=cut
2811 2921
2812# non-persistent channels (usually the info channel) 2922# non-persistent channels (usually the info channel)
2813our %CHANNEL = ( 2923our %CHANNEL = (
2924 "c/motd" => {
2925 id => "infobox",
2926 title => "MOTD",
2927 reply => undef,
2928 tooltip => "The message of the day",
2929 },
2814 "c/identify" => { 2930 "c/identify" => {
2815 id => "infobox", 2931 id => "infobox",
2816 title => "Identify", 2932 title => "Identify",
2817 reply => undef, 2933 reply => undef,
2818 tooltip => "Items recently identified", 2934 tooltip => "Items recently identified",
… …
2820 "c/examine" => { 2936 "c/examine" => {
2821 id => "infobox", 2937 id => "infobox",
2822 title => "Examine", 2938 title => "Examine",
2823 reply => undef, 2939 reply => undef,
2824 tooltip => "Signs and other items you examined", 2940 tooltip => "Signs and other items you examined",
2941 },
2942 "c/shopinfo" => {
2943 id => "infobox",
2944 title => "Shop Info",
2945 reply => undef,
2946 tooltip => "What your bargaining skill tells you about the shop",
2825 }, 2947 },
2826 "c/book" => { 2948 "c/book" => {
2827 id => "infobox", 2949 id => "infobox",
2828 title => "Book", 2950 title => "Book",
2829 reply => undef, 2951 reply => undef,
… …
2845 id => "infobox", 2967 id => "infobox",
2846 title => "Body Parts", 2968 title => "Body Parts",
2847 reply => undef, 2969 reply => undef,
2848 tooltip => "Shows which body parts you posess and are available", 2970 tooltip => "Shows which body parts you posess and are available",
2849 }, 2971 },
2972 "c/statistics" => {
2973 id => "infobox",
2974 title => "Statistics",
2975 reply => undef,
2976 tooltip => "Shows your primary statistics",
2977 },
2978 "c/skills" => {
2979 id => "infobox",
2980 title => "Skills",
2981 reply => undef,
2982 tooltip => "Shows your experience per skill and item power",
2983 },
2984 "c/shopitems" => {
2985 id => "infobox",
2986 title => "Shop Items",
2987 reply => undef,
2988 tooltip => "Shows the items currently for sale in this shop",
2989 },
2990 "c/resistances" => {
2991 id => "infobox",
2992 title => "Resistances",
2993 reply => undef,
2994 tooltip => "Shows your resistances",
2995 },
2996 "c/pets" => {
2997 id => "infobox",
2998 title => "Pets",
2999 reply => undef,
3000 tooltip => "Shows information abotu your pets/a specific pet",
3001 },
3002 "c/perceiveself" => {
3003 id => "infobox",
3004 title => "Perceive Self",
3005 reply => undef,
3006 tooltip => "You gained detailed knowledge about yourself",
3007 },
2850 "c/uptime" => { 3008 "c/uptime" => {
2851 id => "infobox", 3009 id => "infobox",
2852 title => "Uptime", 3010 title => "Uptime",
2853 reply => undef, 3011 reply => undef,
2854 tooltip => "How long the server has been running since last restart", 3012 tooltip => "How long the server has been running since last restart",
… …
2863 id => "party", 3021 id => "party",
2864 title => "Party", 3022 title => "Party",
2865 reply => "gsay ", 3023 reply => "gsay ",
2866 tooltip => "Messages and chat related to your party", 3024 tooltip => "Messages and chat related to your party",
2867 }, 3025 },
3026 "c/death" => {
3027 id => "death",
3028 title => "Death",
3029 reply => undef,
3030 tooltip => "Reason for and more info about your most recent death",
3031 },
3032 "c/say" => $SAY_CHANNEL,
3033 "c/chat" => $CHAT_CHANNEL,
2868); 3034);
2869 3035
2870sub cf::client::send_msg { 3036sub cf::client::send_msg {
2871 my ($self, $channel, $msg, $color, @extra) = @_; 3037 my ($self, $channel, $msg, $color, @extra) = @_;
2872 3038
2873 $msg = $self->pl->expand_cfpod ($msg); 3039 $msg = $self->pl->expand_cfpod ($msg)
3040 unless $color & cf::NDI_VERBATIM;
2874 3041
2875 $color &= cf::NDI_CLIENT_MASK; # just in case... 3042 $color &= cf::NDI_CLIENT_MASK; # just in case...
2876 3043
2877 # check predefined channels, for the benefit of C 3044 # check predefined channels, for the benefit of C
2878 if ($CHANNEL{$channel}) { 3045 if ($CHANNEL{$channel}) {
2879 $channel = $CHANNEL{$channel}; 3046 $channel = $CHANNEL{$channel};
2880 3047
2881 $self->ext_msg (channel_info => $channel) 3048 $self->ext_msg (channel_info => $channel);
2882 if $self->can_msg;
2883
2884 $channel = $channel->{id}; 3049 $channel = $channel->{id};
2885 3050
2886 } elsif (ref $channel) { 3051 } elsif (ref $channel) {
2887 # send meta info to client, if not yet sent 3052 # send meta info to client, if not yet sent
2888 unless (exists $self->{channel}{$channel->{id}}) { 3053 unless (exists $self->{channel}{$channel->{id}}) {
2889 $self->{channel}{$channel->{id}} = $channel; 3054 $self->{channel}{$channel->{id}} = $channel;
2890 $self->ext_msg (channel_info => $channel) 3055 $self->ext_msg (channel_info => $channel);
2891 if $self->can_msg;
2892 } 3056 }
2893 3057
2894 $channel = $channel->{id}; 3058 $channel = $channel->{id};
2895 } 3059 }
2896 3060
2897 return unless @extra || length $msg; 3061 return unless @extra || length $msg;
2898 3062
2899 if ($self->can_msg) {
2900 # default colour, mask it out 3063 # default colour, mask it out
2901 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3064 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2902 if $color & cf::NDI_DEF; 3065 if $color & cf::NDI_DEF;
2903 3066
2904 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3067 my $pkt = "msg "
3068 . $self->{json_coder}->encode (
2905 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3069 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2906 } else { 3070 );
2907 if ($color >= 0) {
2908 # replace some tags by gcfclient-compatible ones
2909 for ($msg) {
2910 1 while
2911 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2912 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2913 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2914 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2915 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2916 }
2917 3071
2918 $color &= cf::NDI_COLOR_MASK; 3072 $self->send_big_packet ($pkt);
2919
2920 utf8::encode $msg;
2921
2922 if (0 && $msg =~ /\[/) {
2923 # COMMAND/INFO
2924 $self->send_packet ("drawextinfo $color 10 8 $msg")
2925 } else {
2926 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2927 $self->send_packet ("drawinfo $color $msg")
2928 }
2929 }
2930 }
2931} 3073}
2932 3074
2933=item $client->ext_msg ($type, @msg) 3075=item $client->ext_msg ($type, @msg)
2934 3076
2935Sends an ext event to the client. 3077Sends an ext event to the client.
… …
2938 3080
2939sub cf::client::ext_msg($$@) { 3081sub cf::client::ext_msg($$@) {
2940 my ($self, $type, @msg) = @_; 3082 my ($self, $type, @msg) = @_;
2941 3083
2942 if ($self->extcmd == 2) { 3084 if ($self->extcmd == 2) {
2943 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3085 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2944 } elsif ($self->extcmd == 1) { # TODO: remove 3086 } elsif ($self->extcmd == 1) { # TODO: remove
2945 push @msg, msgtype => "event_$type"; 3087 push @msg, msgtype => "event_$type";
2946 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3088 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2947 } 3089 }
2948} 3090}
2949 3091
2950=item $client->ext_reply ($msgid, @msg) 3092=item $client->ext_reply ($msgid, @msg)
2951 3093
… …
2955 3097
2956sub cf::client::ext_reply($$@) { 3098sub cf::client::ext_reply($$@) {
2957 my ($self, $id, @msg) = @_; 3099 my ($self, $id, @msg) = @_;
2958 3100
2959 if ($self->extcmd == 2) { 3101 if ($self->extcmd == 2) {
2960 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3102 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2961 } elsif ($self->extcmd == 1) { 3103 } elsif ($self->extcmd == 1) {
2962 #TODO: version 1, remove 3104 #TODO: version 1, remove
2963 unshift @msg, msgtype => "reply", msgid => $id; 3105 unshift @msg, msgtype => "reply", msgid => $id;
2964 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3106 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2965 } 3107 }
2966} 3108}
2967 3109
2968=item $success = $client->query ($flags, "text", \&cb) 3110=item $success = $client->query ($flags, "text", \&cb)
2969 3111
… …
3040 3182
3041 $ns->ext_reply ($reply, @reply) 3183 $ns->ext_reply ($reply, @reply)
3042 if $reply; 3184 if $reply;
3043 3185
3044 } else { 3186 } else {
3045 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3187 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3046 } 3188 }
3047 3189
3048 cf::override; 3190 cf::override;
3049 }, 3191 },
3050); 3192);
… …
3070 3212
3071 $coro 3213 $coro
3072} 3214}
3073 3215
3074cf::client->attach ( 3216cf::client->attach (
3075 on_destroy => sub { 3217 on_client_destroy => sub {
3076 my ($ns) = @_; 3218 my ($ns) = @_;
3077 3219
3078 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3220 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3079 }, 3221 },
3080); 3222);
… …
3096our $safe_hole = new Safe::Hole; 3238our $safe_hole = new Safe::Hole;
3097 3239
3098$SIG{FPE} = 'IGNORE'; 3240$SIG{FPE} = 'IGNORE';
3099 3241
3100$safe->permit_only (Opcode::opset qw( 3242$safe->permit_only (Opcode::opset qw(
3101 :base_core :base_mem :base_orig :base_math 3243 :base_core :base_mem :base_orig :base_math :base_loop
3102 grepstart grepwhile mapstart mapwhile 3244 grepstart grepwhile mapstart mapwhile
3103 sort time 3245 sort time
3104)); 3246));
3105 3247
3106# here we export the classes and methods available to script code 3248# here we export the classes and methods available to script code
… …
3110The following functions and methods are available within a safe environment: 3252The following functions and methods are available within a safe environment:
3111 3253
3112 cf::object 3254 cf::object
3113 contr pay_amount pay_player map x y force_find force_add destroy 3255 contr pay_amount pay_player map x y force_find force_add destroy
3114 insert remove name archname title slaying race decrease split 3256 insert remove name archname title slaying race decrease split
3257 value
3115 3258
3116 cf::object::player 3259 cf::object::player
3117 player 3260 player
3118 3261
3119 cf::player 3262 cf::player
… …
3125=cut 3268=cut
3126 3269
3127for ( 3270for (
3128 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3271 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3129 insert remove inv nrof name archname title slaying race 3272 insert remove inv nrof name archname title slaying race
3130 decrease split destroy)], 3273 decrease split destroy change_exp value msg lore send_msg)],
3131 ["cf::object::player" => qw(player)], 3274 ["cf::object::player" => qw(player)],
3132 ["cf::player" => qw(peaceful)], 3275 ["cf::player" => qw(peaceful send_msg)],
3133 ["cf::map" => qw(trigger)], 3276 ["cf::map" => qw(trigger)],
3134) { 3277) {
3135 no strict 'refs';
3136 my ($pkg, @funs) = @$_; 3278 my ($pkg, @funs) = @$_;
3137 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3279 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3138 for @funs; 3280 for @funs;
3139} 3281}
3140 3282
… …
3155 3297
3156 my $qcode = $code; 3298 my $qcode = $code;
3157 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3299 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3158 $qcode =~ s/\n/\\n/g; 3300 $qcode =~ s/\n/\\n/g;
3159 3301
3302 %vars = (_dummy => 0) unless %vars;
3303
3304 my @res;
3160 local $_; 3305 local $_;
3161 local @safe::cf::_safe_eval_args = values %vars;
3162 3306
3163 my $eval = 3307 my $eval =
3164 "do {\n" 3308 "do {\n"
3165 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3309 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3166 . "#line 0 \"{$qcode}\"\n" 3310 . "#line 0 \"{$qcode}\"\n"
3167 . $code 3311 . $code
3168 . "\n}" 3312 . "\n}"
3169 ; 3313 ;
3170 3314
3315 if ($CFG{safe_eval}) {
3171 sub_generation_inc; 3316 sub_generation_inc;
3317 local @safe::cf::_safe_eval_args = values %vars;
3172 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3318 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3173 sub_generation_inc; 3319 sub_generation_inc;
3320 } else {
3321 local @cf::_safe_eval_args = values %vars;
3322 @res = wantarray ? eval eval : scalar eval $eval;
3323 }
3174 3324
3175 if ($@) { 3325 if ($@) {
3176 warn "$@"; 3326 warn "$@",
3177 warn "while executing safe code '$code'\n"; 3327 "while executing safe code '$code'\n",
3178 warn "with arguments " . (join " ", %vars) . "\n"; 3328 "with arguments " . (join " ", %vars) . "\n";
3179 } 3329 }
3180 3330
3181 wantarray ? @res : $res[0] 3331 wantarray ? @res : $res[0]
3182} 3332}
3183 3333
… …
3197=cut 3347=cut
3198 3348
3199sub register_script_function { 3349sub register_script_function {
3200 my ($fun, $cb) = @_; 3350 my ($fun, $cb) = @_;
3201 3351
3202 no strict 'refs'; 3352 $fun = "safe::$fun" if $CFG{safe_eval};
3203 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3353 *$fun = $safe_hole->wrap ($cb);
3204} 3354}
3205 3355
3206=back 3356=back
3207 3357
3208=cut 3358=cut
3209 3359
3210############################################################################# 3360#############################################################################
3211# the server's init and main functions 3361# the server's init and main functions
3362
3363# async inc loader. yay.
3364sub inc_loader {
3365 my $mod = $_[1];
3366
3367 if (in_main && !tick_inhibit) {
3368 Carp::cluck "ERROR: attempted synchronous perl module load ($mod)";
3369 } else {
3370 debug "loading perl module $mod\n";
3371 }
3372
3373 # 1. find real file
3374 for my $dir (@ORIG_INC) {
3375 warn "$dir/$mod\n";#d#
3376 ref $dir and next;
3377 0 <= Coro::AIO::aio_load "$dir/$mod", my $data
3378 or next;
3379
3380 $data = "#line 1 $dir/$mod\n$data";
3381
3382 open my $fh, "<", \$data or die;
3383
3384 return $fh;
3385 }
3386
3387 ()
3388}
3389
3390sub init_inc {
3391 # save original @INC
3392 @ORIG_INC = ($LIBDIR, @INC) unless @ORIG_INC;
3393
3394 # make sure we can do scalar-opens
3395 open my $dummy, "<", \my $dummy2;
3396
3397 # execute some stuff so perl load's some of the core modules
3398 /Ü/ =~ /ü/i;
3399 eval { &Storable::nstore_fd };
3400
3401 @INC = (\&inc_loader, @ORIG_INC); # @ORIG_INC is needed for DynaLoader, AutoLoad etc.
3402
3403 debug "module loading will be asynchronous from this point on.";
3404}
3212 3405
3213sub load_facedata($) { 3406sub load_facedata($) {
3214 my ($path) = @_; 3407 my ($path) = @_;
3215 3408
3216 # HACK to clear player env face cache, we need some signal framework 3409 # HACK to clear player env face cache, we need some signal framework
3217 # for this (global event?) 3410 # for this (global event?)
3218 %ext::player_env::MUSIC_FACE_CACHE = (); 3411 %ext::player_env::MUSIC_FACE_CACHE = ();
3219 3412
3220 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3413 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3221 3414
3222 warn "loading facedata from $path\n"; 3415 trace "loading facedata from $path\n";
3223 3416
3224 my $facedata; 3417 my $facedata;
3225 0 < aio_load $path, $facedata 3418 0 < aio_load $path, $facedata
3226 or die "$path: $!"; 3419 or die "$path: $!";
3227 3420
… …
3229 3422
3230 $facedata->{version} == 2 3423 $facedata->{version} == 2
3231 or cf::cleanup "$path: version mismatch, cannot proceed."; 3424 or cf::cleanup "$path: version mismatch, cannot proceed.";
3232 3425
3233 # patch in the exptable 3426 # patch in the exptable
3427 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3234 $facedata->{resource}{"res/exp_table"} = { 3428 $facedata->{resource}{"res/exp_table"} = {
3235 type => FT_RSRC, 3429 type => FT_RSRC,
3236 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3430 data => $exp_table,
3431 hash => (Digest::MD5::md5 $exp_table),
3237 }; 3432 };
3238 cf::cede_to_tick; 3433 cf::cede_to_tick;
3239 3434
3240 { 3435 {
3241 my $faces = $facedata->{faceinfo}; 3436 my $faces = $facedata->{faceinfo};
… …
3243 while (my ($face, $info) = each %$faces) { 3438 while (my ($face, $info) = each %$faces) {
3244 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3439 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3245 3440
3246 cf::face::set_visibility $idx, $info->{visibility}; 3441 cf::face::set_visibility $idx, $info->{visibility};
3247 cf::face::set_magicmap $idx, $info->{magicmap}; 3442 cf::face::set_magicmap $idx, $info->{magicmap};
3248 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3443 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3249 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3444 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3250 3445
3251 cf::cede_to_tick; 3446 cf::cede_to_tick;
3252 } 3447 }
3253 3448
3254 while (my ($face, $info) = each %$faces) { 3449 while (my ($face, $info) = each %$faces) {
… …
3259 3454
3260 if (my $smooth = cf::face::find $info->{smooth}) { 3455 if (my $smooth = cf::face::find $info->{smooth}) {
3261 cf::face::set_smooth $idx, $smooth; 3456 cf::face::set_smooth $idx, $smooth;
3262 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3457 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3263 } else { 3458 } else {
3264 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3459 error "smooth face '$info->{smooth}' not found for face '$face'";
3265 } 3460 }
3266 3461
3267 cf::cede_to_tick; 3462 cf::cede_to_tick;
3268 } 3463 }
3269 } 3464 }
… …
3278 3473
3279 cf::anim::invalidate_all; # d'oh 3474 cf::anim::invalidate_all; # d'oh
3280 } 3475 }
3281 3476
3282 { 3477 {
3283 # TODO: for gcfclient pleasure, we should give resources
3284 # that gcfclient doesn't grok a >10000 face index.
3285 my $res = $facedata->{resource}; 3478 my $res = $facedata->{resource};
3286 3479
3287 while (my ($name, $info) = each %$res) { 3480 while (my ($name, $info) = each %$res) {
3288 if (defined $info->{type}) { 3481 if (defined $info->{type}) {
3289 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3482 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3290 my $data;
3291 3483
3292 if ($info->{type} & 1) { 3484 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3293 # prepend meta info
3294
3295 my $meta = $enc->encode ({
3296 name => $name,
3297 %{ $info->{meta} || {} },
3298 });
3299
3300 $data = pack "(w/a*)*", $meta, $info->{data};
3301 } else {
3302 $data = $info->{data};
3303 }
3304
3305 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3306 cf::face::set_type $idx, $info->{type}; 3485 cf::face::set_type $idx, $info->{type};
3307 } else { 3486 } else {
3308 $RESOURCE{$name} = $info; 3487 $RESOURCE{$name} = $info; # unused
3309 } 3488 }
3310 3489
3311 cf::cede_to_tick; 3490 cf::cede_to_tick;
3312 } 3491 }
3313 } 3492 }
3314 3493
3315 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3494 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3316 3495
3317 1 3496 1
3318} 3497}
3319
3320cf::global->attach (on_resource_update => sub {
3321 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3322 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3323
3324 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3325 my $sound = $soundconf->{compat}[$_]
3326 or next;
3327
3328 my $face = cf::face::find "sound/$sound->[1]";
3329 cf::sound::set $sound->[0] => $face;
3330 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3331 }
3332
3333 while (my ($k, $v) = each %{$soundconf->{event}}) {
3334 my $face = cf::face::find "sound/$v";
3335 cf::sound::set $k => $face;
3336 }
3337 }
3338});
3339 3498
3340register_exticmd fx_want => sub { 3499register_exticmd fx_want => sub {
3341 my ($ns, $want) = @_; 3500 my ($ns, $want) = @_;
3342 3501
3343 while (my ($k, $v) = each %$want) { 3502 while (my ($k, $v) = each %$want) {
… …
3382sub reload_treasures { 3541sub reload_treasures {
3383 load_resource_file "$DATADIR/treasures" 3542 load_resource_file "$DATADIR/treasures"
3384 or die "unable to load treasurelists\n"; 3543 or die "unable to load treasurelists\n";
3385} 3544}
3386 3545
3546sub reload_sound {
3547 trace "loading sound config from $DATADIR/sound\n";
3548
3549 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3550 or die "$DATADIR/sound $!";
3551
3552 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3553
3554 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3555 my $sound = $soundconf->{compat}[$_]
3556 or next;
3557
3558 my $face = cf::face::find "sound/$sound->[1]";
3559 cf::sound::set $sound->[0] => $face;
3560 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3561 }
3562
3563 while (my ($k, $v) = each %{$soundconf->{event}}) {
3564 my $face = cf::face::find "sound/$v";
3565 cf::sound::set $k => $face;
3566 }
3567}
3568
3387sub reload_resources { 3569sub reload_resources {
3388 warn "reloading resource files...\n"; 3570 trace "reloading resource files...\n";
3389 3571
3390 reload_facedata; 3572 reload_facedata;
3573 reload_sound;
3391 reload_archetypes; 3574 reload_archetypes;
3392 reload_regions; 3575 reload_regions;
3393 reload_treasures; 3576 reload_treasures;
3394 3577
3395 warn "finished reloading resource files\n"; 3578 trace "finished reloading resource files\n";
3396}
3397
3398sub init {
3399 my $guard = freeze_mainloop;
3400
3401 reload_resources;
3402} 3579}
3403 3580
3404sub reload_config { 3581sub reload_config {
3582 trace "reloading config file...\n";
3583
3405 open my $fh, "<:utf8", "$CONFDIR/config" 3584 open my $fh, "<:utf8", "$CONFDIR/config"
3406 or return; 3585 or return;
3407 3586
3408 local $/; 3587 local $/;
3409 *CFG = YAML::Load <$fh>; 3588 *CFG = YAML::XS::Load scalar <$fh>;
3410 3589
3411 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3590 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3412 3591
3413 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3592 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3414 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3593 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3415 3594
3416 if (exists $CFG{mlockall}) { 3595 if (exists $CFG{mlockall}) {
… …
3418 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3597 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3419 and die "WARNING: m(un)lockall failed: $!\n"; 3598 and die "WARNING: m(un)lockall failed: $!\n";
3420 }; 3599 };
3421 warn $@ if $@; 3600 warn $@ if $@;
3422 } 3601 }
3602
3603 trace "finished reloading resource files\n";
3604}
3605
3606sub pidfile() {
3607 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3608 or die "$PIDFILE: $!";
3609 flock $fh, &Fcntl::LOCK_EX
3610 or die "$PIDFILE: flock: $!";
3611 $fh
3612}
3613
3614# make sure only one server instance is running at any one time
3615sub atomic {
3616 my $fh = pidfile;
3617
3618 my $pid = <$fh>;
3619 kill 9, $pid if $pid > 0;
3620
3621 seek $fh, 0, 0;
3622 print $fh $$;
3623}
3624
3625sub main_loop {
3626 trace "EV::loop starting\n";
3627 if (1) {
3628 EV::loop;
3629 }
3630 trace "EV::loop returned\n";
3631 goto &main_loop unless $REALLY_UNLOOP;
3423} 3632}
3424 3633
3425sub main { 3634sub main {
3635 cf::init_globals; # initialise logging
3636
3637 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3638 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3639 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3640 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3641
3642 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3643
3426 # we must not ever block the main coroutine 3644 # we must not ever block the main coroutine
3427 local $Coro::idle = sub { 3645 local $Coro::idle = sub {
3428 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3646 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3429 (async { 3647 (async {
3430 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3648 $Coro::current->{desc} = "IDLE BUG HANDLER";
3431 EV::loop EV::LOOP_ONESHOT; 3649 EV::loop EV::LOOP_ONESHOT;
3432 })->prio (Coro::PRIO_MAX); 3650 })->prio (Coro::PRIO_MAX);
3433 }; 3651 };
3434 3652
3435 { 3653 evthread_start IO::AIO::poll_fileno;
3436 my $guard = freeze_mainloop; 3654
3655 cf::sync_job {
3656 init_inc;
3657
3658 cf::init_experience;
3659 cf::init_anim;
3660 cf::init_attackmess;
3661 cf::init_dynamic;
3662
3663 cf::load_settings;
3664 cf::load_materials;
3665
3666 reload_resources;
3437 reload_config; 3667 reload_config;
3438 db_init; 3668 db_init;
3669
3670 cf::init_uuid;
3671 cf::init_signals;
3672 cf::init_skills;
3673
3674 cf::init_beforeplay;
3675
3676 atomic;
3677
3439 load_extensions; 3678 load_extensions;
3440 3679
3441 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3680 utime time, time, $RUNTIMEFILE;
3442 evthread_start IO::AIO::poll_fileno; 3681
3682 # no (long-running) fork's whatsoever before this point(!)
3683 use POSIX ();
3684 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3685
3686 (pop @POST_INIT)->(0) while @POST_INIT;
3443 } 3687 };
3444 3688
3445 EV::loop; 3689 cf::object::thawer::errors_are_fatal 0;
3690 info "parse errors in files are no longer fatal from this point on.\n";
3691
3692 my $free_main; $free_main = EV::idle sub {
3693 undef $free_main;
3694 undef &main; # free gobs of memory :)
3695 };
3696
3697 goto &main_loop;
3446} 3698}
3447 3699
3448############################################################################# 3700#############################################################################
3449# initialisation and cleanup 3701# initialisation and cleanup
3450 3702
3451# install some emergency cleanup handlers 3703# install some emergency cleanup handlers
3452BEGIN { 3704BEGIN {
3453 our %SIGWATCHER = (); 3705 our %SIGWATCHER = ();
3454 for my $signal (qw(INT HUP TERM)) { 3706 for my $signal (qw(INT HUP TERM)) {
3455 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3707 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3456 cf::cleanup "SIG$signal"; 3708 cf::cleanup "SIG$signal";
3457 }; 3709 };
3458 } 3710 }
3459} 3711}
3460 3712
3461sub write_runtime_sync { 3713sub write_runtime_sync {
3462 my $runtime = "$LOCALDIR/runtime"; 3714 my $t0 = AE::time;
3463 3715
3464 # first touch the runtime file to show we are still running: 3716 # first touch the runtime file to show we are still running:
3465 # the fsync below can take a very very long time. 3717 # the fsync below can take a very very long time.
3466 3718
3467 IO::AIO::aio_utime $runtime, undef, undef; 3719 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3468 3720
3469 my $guard = cf::lock_acquire "write_runtime"; 3721 my $guard = cf::lock_acquire "write_runtime";
3470 3722
3471 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3723 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3472 or return; 3724 or return;
3473 3725
3474 my $value = $cf::RUNTIME + 90 + 10; 3726 my $value = $cf::RUNTIME + 90 + 10;
3475 # 10 is the runtime save interval, for a monotonic clock 3727 # 10 is the runtime save interval, for a monotonic clock
3476 # 60 allows for the watchdog to kill the server. 3728 # 60 allows for the watchdog to kill the server.
… …
3486 aio_utime $fh, undef, undef; 3738 aio_utime $fh, undef, undef;
3487 3739
3488 close $fh 3740 close $fh
3489 or return; 3741 or return;
3490 3742
3491 aio_rename "$runtime~", $runtime 3743 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3492 and return; 3744 and return;
3493 3745
3494 warn "runtime file written.\n"; 3746 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3495 3747
3496 1 3748 1
3497} 3749}
3498 3750
3499our $uuid_lock; 3751our $uuid_lock;
… …
3508 my $uuid = "$LOCALDIR/uuid"; 3760 my $uuid = "$LOCALDIR/uuid";
3509 3761
3510 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 3762 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3511 or return; 3763 or return;
3512 3764
3513 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; 3765 my $value = uuid_seq uuid_cur;
3766
3767 unless ($value) {
3768 info "cowardly refusing to write zero uuid value!\n";
3769 return;
3770 }
3771
3772 my $value = uuid_str $value + $uuid_skip;
3514 $uuid_skip = 0; 3773 $uuid_skip = 0;
3515 3774
3516 (aio_write $fh, 0, (length $value), $value, 0) <= 0 3775 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3517 and return; 3776 and return;
3518 3777
… …
3524 or return; 3783 or return;
3525 3784
3526 aio_rename "$uuid~", $uuid 3785 aio_rename "$uuid~", $uuid
3527 and return; 3786 and return;
3528 3787
3529 warn "uuid file written ($value).\n"; 3788 trace "uuid file written ($value).\n";
3530 3789
3531 1 3790 1
3532 3791
3533} 3792}
3534 3793
… …
3540} 3799}
3541 3800
3542sub emergency_save() { 3801sub emergency_save() {
3543 my $freeze_guard = cf::freeze_mainloop; 3802 my $freeze_guard = cf::freeze_mainloop;
3544 3803
3545 warn "enter emergency perl save\n"; 3804 info "emergency_perl_save: enter\n";
3805
3806 # this is a trade-off: we want to be very quick here, so
3807 # save all maps without fsync, and later call a global sync
3808 # (which in turn might be very very slow)
3809 local $USE_FSYNC = 0;
3546 3810
3547 cf::sync_job { 3811 cf::sync_job {
3812 cf::write_runtime_sync; # external watchdog should not bark
3813
3548 # use a peculiar iteration method to avoid tripping on perl 3814 # use a peculiar iteration method to avoid tripping on perl
3549 # refcount bugs in for. also avoids problems with players 3815 # refcount bugs in for. also avoids problems with players
3550 # and maps saved/destroyed asynchronously. 3816 # and maps saved/destroyed asynchronously.
3551 warn "begin emergency player save\n"; 3817 info "emergency_perl_save: begin player save\n";
3552 for my $login (keys %cf::PLAYER) { 3818 for my $login (keys %cf::PLAYER) {
3553 my $pl = $cf::PLAYER{$login} or next; 3819 my $pl = $cf::PLAYER{$login} or next;
3554 $pl->valid or next; 3820 $pl->valid or next;
3555 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3821 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3556 $pl->save; 3822 $pl->save;
3557 } 3823 }
3558 warn "end emergency player save\n"; 3824 info "emergency_perl_save: end player save\n";
3559 3825
3560 warn "begin emergency map save\n"; 3826 cf::write_runtime_sync; # external watchdog should not bark
3827
3828 info "emergency_perl_save: begin map save\n";
3561 for my $path (keys %cf::MAP) { 3829 for my $path (keys %cf::MAP) {
3562 my $map = $cf::MAP{$path} or next; 3830 my $map = $cf::MAP{$path} or next;
3563 $map->valid or next; 3831 $map->valid or next;
3564 $map->save; 3832 $map->save;
3565 } 3833 }
3566 warn "end emergency map save\n"; 3834 info "emergency_perl_save: end map save\n";
3567 3835
3568 warn "begin emergency database checkpoint\n"; 3836 cf::write_runtime_sync; # external watchdog should not bark
3837
3838 info "emergency_perl_save: begin database checkpoint\n";
3569 BDB::db_env_txn_checkpoint $DB_ENV; 3839 BDB::db_env_txn_checkpoint $DB_ENV;
3570 warn "end emergency database checkpoint\n"; 3840 info "emergency_perl_save: end database checkpoint\n";
3571 3841
3572 warn "begin write uuid\n"; 3842 info "emergency_perl_save: begin write uuid\n";
3573 write_uuid_sync 1; 3843 write_uuid_sync 1;
3574 warn "end write uuid\n"; 3844 info "emergency_perl_save: end write uuid\n";
3845
3846 cf::write_runtime_sync; # external watchdog should not bark
3847
3848 trace "emergency_perl_save: syncing database to disk";
3849 BDB::db_env_txn_checkpoint $DB_ENV;
3850
3851 info "emergency_perl_save: starting sync\n";
3852 IO::AIO::aio_sync sub {
3853 info "emergency_perl_save: finished sync\n";
3854 };
3855
3856 cf::write_runtime_sync; # external watchdog should not bark
3857
3858 trace "emergency_perl_save: flushing outstanding aio requests";
3859 while (IO::AIO::nreqs || BDB::nreqs) {
3860 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3861 }
3862
3863 cf::write_runtime_sync; # external watchdog should not bark
3575 }; 3864 };
3576 3865
3577 warn "leave emergency perl save\n"; 3866 info "emergency_perl_save: leave\n";
3578} 3867}
3579 3868
3580sub post_cleanup { 3869sub post_cleanup {
3581 my ($make_core) = @_; 3870 my ($make_core) = @_;
3582 3871
3872 IO::AIO::flush;
3873
3583 warn Carp::longmess "post_cleanup backtrace" 3874 error Carp::longmess "post_cleanup backtrace"
3584 if $make_core; 3875 if $make_core;
3876
3877 my $fh = pidfile;
3878 unlink $PIDFILE if <$fh> == $$;
3879}
3880
3881# a safer delete_package, copied from Symbol
3882sub clear_package($) {
3883 my $pkg = shift;
3884
3885 # expand to full symbol table name if needed
3886 unless ($pkg =~ /^main::.*::$/) {
3887 $pkg = "main$pkg" if $pkg =~ /^::/;
3888 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3889 $pkg .= '::' unless $pkg =~ /::$/;
3890 }
3891
3892 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3893 my $stem_symtab = *{$stem}{HASH};
3894
3895 defined $stem_symtab and exists $stem_symtab->{$leaf}
3896 or return;
3897
3898 # clear all symbols
3899 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3900 for my $name (keys %$leaf_symtab) {
3901 _gv_clear *{"$pkg$name"};
3902# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3903 }
3585} 3904}
3586 3905
3587sub do_reload_perl() { 3906sub do_reload_perl() {
3588 # can/must only be called in main 3907 # can/must only be called in main
3589 if ($Coro::current != $Coro::main) { 3908 if (in_main) {
3590 warn "can only reload from main coroutine"; 3909 error "can only reload from main coroutine";
3591 return; 3910 return;
3592 } 3911 }
3593 3912
3913 return if $RELOAD++;
3914
3915 my $t1 = AE::time;
3916
3917 while ($RELOAD) {
3594 warn "reloading..."; 3918 info "reloading...";
3595 3919
3596 warn "entering sync_job"; 3920 trace "entering sync_job";
3597 3921
3598 cf::sync_job { 3922 cf::sync_job {
3599 cf::write_runtime_sync; # external watchdog should not bark
3600 cf::emergency_save; 3923 cf::emergency_save;
3601 cf::write_runtime_sync; # external watchdog should not bark
3602 3924
3603 warn "syncing database to disk";
3604 BDB::db_env_txn_checkpoint $DB_ENV;
3605
3606 # if anything goes wrong in here, we should simply crash as we already saved
3607
3608 warn "flushing outstanding aio requests";
3609 for (;;) {
3610 BDB::flush;
3611 IO::AIO::flush;
3612 Coro::cede_notself;
3613 last unless IO::AIO::nreqs || BDB::nreqs;
3614 warn "iterate...";
3615 }
3616
3617 ++$RELOAD;
3618
3619 warn "cancelling all extension coros"; 3925 trace "cancelling all extension coros";
3620 $_->cancel for values %EXT_CORO; 3926 $_->cancel for values %EXT_CORO;
3621 %EXT_CORO = (); 3927 %EXT_CORO = ();
3622 3928
3623 warn "removing commands"; 3929 trace "removing commands";
3624 %COMMAND = (); 3930 %COMMAND = ();
3625 3931
3626 warn "removing ext/exti commands"; 3932 trace "removing ext/exti commands";
3627 %EXTCMD = (); 3933 %EXTCMD = ();
3628 %EXTICMD = (); 3934 %EXTICMD = ();
3629 3935
3630 warn "unloading/nuking all extensions"; 3936 trace "unloading/nuking all extensions";
3631 for my $pkg (@EXTS) { 3937 for my $pkg (@EXTS) {
3632 warn "... unloading $pkg"; 3938 trace "... unloading $pkg";
3633 3939
3634 if (my $cb = $pkg->can ("unload")) { 3940 if (my $cb = $pkg->can ("unload")) {
3635 eval { 3941 eval {
3636 $cb->($pkg); 3942 $cb->($pkg);
3637 1 3943 1
3638 } or warn "$pkg unloaded, but with errors: $@"; 3944 } or error "$pkg unloaded, but with errors: $@";
3945 }
3946
3947 trace "... clearing $pkg";
3948 clear_package $pkg;
3639 } 3949 }
3640 3950
3641 warn "... nuking $pkg";
3642 Symbol::delete_package $pkg;
3643 }
3644
3645 warn "unloading all perl modules loaded from $LIBDIR"; 3951 trace "unloading all perl modules loaded from $LIBDIR";
3646 while (my ($k, $v) = each %INC) { 3952 while (my ($k, $v) = each %INC) {
3647 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3953 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3648 3954
3649 warn "... unloading $k"; 3955 trace "... unloading $k";
3650 delete $INC{$k}; 3956 delete $INC{$k};
3651 3957
3652 $k =~ s/\.pm$//; 3958 $k =~ s/\.pm$//;
3653 $k =~ s/\//::/g; 3959 $k =~ s/\//::/g;
3654 3960
3655 if (my $cb = $k->can ("unload_module")) { 3961 if (my $cb = $k->can ("unload_module")) {
3656 $cb->(); 3962 $cb->();
3963 }
3964
3965 clear_package $k;
3657 } 3966 }
3658 3967
3659 Symbol::delete_package $k;
3660 }
3661
3662 warn "getting rid of safe::, as good as possible"; 3968 trace "getting rid of safe::, as good as possible";
3663 Symbol::delete_package "safe::$_" 3969 clear_package "safe::$_"
3664 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3970 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3665 3971
3666 warn "unloading cf.pm \"a bit\""; 3972 trace "unloading cf.pm \"a bit\"";
3667 delete $INC{"cf.pm"}; 3973 delete $INC{"cf.pm"};
3668 delete $INC{"cf/pod.pm"}; 3974 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3669 3975
3670 # don't, removes xs symbols, too, 3976 # don't, removes xs symbols, too,
3671 # and global variables created in xs 3977 # and global variables created in xs
3672 #Symbol::delete_package __PACKAGE__; 3978 #clear_package __PACKAGE__;
3673 3979
3674 warn "unload completed, starting to reload now"; 3980 info "unload completed, starting to reload now";
3675 3981
3676 warn "reloading cf.pm"; 3982 trace "reloading cf.pm";
3677 require cf; 3983 require cf;
3678 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3984 cf::_connect_to_perl_1;
3679 3985
3680 warn "loading config and database again"; 3986 trace "loading config and database again";
3681 cf::reload_config; 3987 cf::reload_config;
3682 3988
3683 warn "loading extensions"; 3989 trace "loading extensions";
3684 cf::load_extensions; 3990 cf::load_extensions;
3685 3991
3992 if ($REATTACH_ON_RELOAD) {
3686 warn "reattaching attachments to objects/players"; 3993 trace "reattaching attachments to objects/players";
3687 _global_reattach; # objects, sockets 3994 _global_reattach; # objects, sockets
3688 warn "reattaching attachments to maps"; 3995 trace "reattaching attachments to maps";
3689 reattach $_ for values %MAP; 3996 reattach $_ for values %MAP;
3690 warn "reattaching attachments to players"; 3997 trace "reattaching attachments to players";
3691 reattach $_ for values %PLAYER; 3998 reattach $_ for values %PLAYER;
3999 }
3692 4000
4001 trace "running post_init jobs";
4002 (pop @POST_INIT)->(1) while @POST_INIT;
4003
3693 warn "leaving sync_job"; 4004 trace "leaving sync_job";
3694 4005
3695 1 4006 1
3696 } or do { 4007 } or do {
3697 warn $@; 4008 error $@;
3698 cf::cleanup "error while reloading, exiting."; 4009 cf::cleanup "error while reloading, exiting.";
4010 };
4011
4012 info "reloaded";
4013 --$RELOAD;
3699 }; 4014 }
3700 4015
3701 warn "reloaded"; 4016 $t1 = AE::time - $t1;
4017 info "reload completed in ${t1}s\n";
3702}; 4018};
3703 4019
3704our $RELOAD_WATCHER; # used only during reload 4020our $RELOAD_WATCHER; # used only during reload
3705 4021
3706sub reload_perl() { 4022sub reload_perl() {
3707 # doing reload synchronously and two reloads happen back-to-back, 4023 # doing reload synchronously and two reloads happen back-to-back,
3708 # coro crashes during coro_state_free->destroy here. 4024 # coro crashes during coro_state_free->destroy here.
3709 4025
4026 $RELOAD_WATCHER ||= cf::async {
4027 Coro::AIO::aio_wait cache_extensions;
4028
3710 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 4029 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3711 do_reload_perl; 4030 do_reload_perl;
3712 undef $RELOAD_WATCHER; 4031 undef $RELOAD_WATCHER;
4032 };
3713 }; 4033 };
3714} 4034}
3715 4035
3716register_command "reload" => sub { 4036register_command "reload" => sub {
3717 my ($who, $arg) = @_; 4037 my ($who, $arg) = @_;
… …
3723 reload_perl; 4043 reload_perl;
3724 }; 4044 };
3725 } 4045 }
3726}; 4046};
3727 4047
3728unshift @INC, $LIBDIR; 4048#############################################################################
3729 4049
3730my $bug_warning = 0; 4050my $bug_warning = 0;
3731 4051
3732our @WAIT_FOR_TICK; 4052our @WAIT_FOR_TICK;
3733our @WAIT_FOR_TICK_BEGIN; 4053our @WAIT_FOR_TICK_BEGIN;
3734 4054
3735sub wait_for_tick { 4055sub wait_for_tick {
3736 return if tick_inhibit || $Coro::current == $Coro::main; 4056 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3737 4057
3738 my $signal = new Coro::Signal; 4058 my $signal = new Coro::Signal;
3739 push @WAIT_FOR_TICK, $signal; 4059 push @WAIT_FOR_TICK, $signal;
3740 $signal->wait; 4060 $signal->wait;
3741} 4061}
3742 4062
3743sub wait_for_tick_begin { 4063sub wait_for_tick_begin {
3744 return if tick_inhibit || $Coro::current == $Coro::main; 4064 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3745 4065
3746 my $signal = new Coro::Signal; 4066 my $signal = new Coro::Signal;
3747 push @WAIT_FOR_TICK_BEGIN, $signal; 4067 push @WAIT_FOR_TICK_BEGIN, $signal;
3748 $signal->wait; 4068 $signal->wait;
3749} 4069}
… …
3755 return; 4075 return;
3756 } 4076 }
3757 4077
3758 cf::server_tick; # one server iteration 4078 cf::server_tick; # one server iteration
3759 4079
4080 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4081
3760 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4082 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3761 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4083 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3762 Coro::async_pool { 4084 Coro::async_pool {
3763 $Coro::current->{desc} = "runtime saver"; 4085 $Coro::current->{desc} = "runtime saver";
3764 write_runtime_sync 4086 write_runtime_sync
3765 or warn "ERROR: unable to write runtime file: $!"; 4087 or error "ERROR: unable to write runtime file: $!";
3766 }; 4088 };
3767 } 4089 }
3768 4090
3769 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4091 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3770 $sig->send; 4092 $sig->send;
… …
3778 4100
3779 if (0) { 4101 if (0) {
3780 if ($NEXT_TICK) { 4102 if ($NEXT_TICK) {
3781 my $jitter = $TICK_START - $NEXT_TICK; 4103 my $jitter = $TICK_START - $NEXT_TICK;
3782 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4104 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3783 warn "jitter $JITTER\n";#d# 4105 debug "jitter $JITTER\n";#d#
3784 } 4106 }
3785 } 4107 }
3786} 4108}
3787 4109
3788{ 4110{
3789 # configure BDB 4111 # configure BDB
3790 4112
3791 BDB::min_parallel 8; 4113 BDB::min_parallel 16;
3792 BDB::max_poll_reqs $TICK * 0.1; 4114 BDB::max_poll_reqs $TICK * 0.1;
3793 $AnyEvent::BDB::WATCHER->priority (1); 4115 $AnyEvent::BDB::WATCHER->priority (1);
3794 4116
3795 unless ($DB_ENV) { 4117 unless ($DB_ENV) {
3796 $DB_ENV = BDB::db_env_create; 4118 $DB_ENV = BDB::db_env_create;
3797 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 4119 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3798 | BDB::LOG_AUTOREMOVE, 1); 4120 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4121 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3799 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 4122 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3800 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 4123 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3801 4124
3802 cf::sync_job { 4125 cf::sync_job {
3803 eval { 4126 eval {
… …
3829{ 4152{
3830 # configure IO::AIO 4153 # configure IO::AIO
3831 4154
3832 IO::AIO::min_parallel 8; 4155 IO::AIO::min_parallel 8;
3833 IO::AIO::max_poll_time $TICK * 0.1; 4156 IO::AIO::max_poll_time $TICK * 0.1;
3834 $AnyEvent::AIO::WATCHER->priority (1); 4157 undef $AnyEvent::AIO::WATCHER;
3835} 4158}
3836 4159
3837my $_log_backtrace; 4160my $_log_backtrace;
3838 4161
3839sub _log_backtrace { 4162sub _log_backtrace {
… …
3842 $msg =~ s/\n//; 4165 $msg =~ s/\n//;
3843 4166
3844 # limit the # of concurrent backtraces 4167 # limit the # of concurrent backtraces
3845 if ($_log_backtrace < 2) { 4168 if ($_log_backtrace < 2) {
3846 ++$_log_backtrace; 4169 ++$_log_backtrace;
4170 my $perl_bt = Carp::longmess $msg;
3847 async { 4171 async {
3848 $Coro::current->{desc} = "abt $msg"; 4172 $Coro::current->{desc} = "abt $msg";
3849 4173
3850 my @bt = fork_call { 4174 my @bt = fork_call {
3851 @addr = map { sprintf "%x", $_ } @addr; 4175 @addr = map { sprintf "%x", $_ } @addr;
… …
3862 } 4186 }
3863 4187
3864 @funcs 4188 @funcs
3865 }; 4189 };
3866 4190
3867 LOG llevInfo, "[ABT] $msg\n"; 4191 LOG llevInfo, "[ABT] $perl_bt\n";
4192 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3868 LOG llevInfo, "[ABT] $_\n" for @bt; 4193 LOG llevInfo, "[ABT] $_\n" for @bt;
3869 --$_log_backtrace; 4194 --$_log_backtrace;
3870 }; 4195 };
3871 } else { 4196 } else {
3872 LOG llevInfo, "[ABT] $msg\n"; 4197 LOG llevInfo, "[ABT] $msg\n";
3873 LOG llevInfo, "[ABT] [suppressed]\n"; 4198 LOG llevInfo, "[ABT] [suppressed]\n";
3874 } 4199 }
3875} 4200}
3876 4201
3877# load additional modules 4202# load additional modules
3878use cf::pod; 4203require "cf/$_.pm" for @EXTRA_MODULES;
4204cf::_connect_to_perl_2;
3879 4205
3880END { cf::emergency_save } 4206END { cf::emergency_save }
3881 4207
38821 42081
3883 4209

Diff Legend

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