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.426 by root, Thu Apr 24 04:40:31 2008 UTC vs.
Revision 1.533 by root, Thu Apr 29 07:59:17 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
25use 5.10.0;
24use utf8; 26use utf8;
25use strict; 27use strict qw(vars subs);
26 28
27use Symbol; 29use Symbol;
28use List::Util; 30use List::Util;
29use Socket; 31use Socket;
30use EV 3.2; 32use EV;
31use Opcode; 33use Opcode;
32use Safe; 34use Safe;
33use Safe::Hole; 35use Safe::Hole;
34use Storable (); 36use Storable ();
37use Carp ();
35 38
39use Guard ();
36use Coro 4.50 (); 40use Coro ();
37use Coro::State; 41use Coro::State;
38use Coro::Handle; 42use Coro::Handle;
39use Coro::EV; 43use Coro::EV;
44use Coro::AnyEvent;
40use Coro::Timer; 45use Coro::Timer;
41use Coro::Signal; 46use Coro::Signal;
42use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
43use Coro::AIO; 50use Coro::AIO;
44use Coro::BDB; 51use Coro::BDB 1.6;
45use Coro::Storable; 52use Coro::Storable;
46use Coro::Util (); 53use Coro::Util ();
47 54
48use JSON::XS 2.01 (); 55use JSON::XS 2.01 ();
49use BDB (); 56use BDB ();
50use Data::Dumper; 57use Data::Dumper;
51use Digest::MD5;
52use Fcntl; 58use Fcntl;
53use YAML (); 59use YAML::XS ();
54use IO::AIO 2.51 (); 60use IO::AIO ();
55use Time::HiRes; 61use Time::HiRes;
56use Compress::LZF; 62use Compress::LZF;
57use Digest::MD5 (); 63use Digest::MD5 ();
64
65AnyEvent::detect;
58 66
59# configure various modules to our taste 67# configure various modules to our taste
60# 68#
61$Storable::canonical = 1; # reduce rsync transfers 69$Storable::canonical = 1; # reduce rsync transfers
62Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 70Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
71
72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
73
74# make sure c-lzf reinitialises itself
75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
63Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
64 77
65$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 78# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
66 80
67sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
68 82
69our %COMMAND = (); 83our %COMMAND = ();
70our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
… …
73our %EXTCMD = (); 87our %EXTCMD = ();
74our %EXTICMD = (); 88our %EXTICMD = ();
75our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
76our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
77 91
78our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
79our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
80 96
81our $CONFDIR = confdir; 97our $CONFDIR = confdir;
82our $DATADIR = datadir; 98our $DATADIR = datadir;
83our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
84our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
85our $MAPDIR = "$DATADIR/" . mapdir; 101our $MAPDIR = "$DATADIR/" . mapdir;
86our $LOCALDIR = localdir; 102our $LOCALDIR = localdir;
87our $TMPDIR = "$LOCALDIR/" . tmpdir; 103our $TMPDIR = "$LOCALDIR/" . tmpdir;
88our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
89our $PLAYERDIR = "$LOCALDIR/" . playerdir; 105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
90our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
91our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
92our %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;
93 118
94our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
95our $AIO_POLL_WATCHER;
96our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
97our $NEXT_TICK; 121our $NEXT_TICK;
98our $USE_FSYNC = 1; # use fsync to write maps - default off 122our $USE_FSYNC = 1; # use fsync to write maps - default on
99 123
100our $BDB_POLL_WATCHER;
101our $BDB_DEADLOCK_WATCHER; 124our $BDB_DEADLOCK_WATCHER;
102our $BDB_CHECKPOINT_WATCHER; 125our $BDB_CHECKPOINT_WATCHER;
103our $BDB_TRICKLE_WATCHER; 126our $BDB_TRICKLE_WATCHER;
104our $DB_ENV; 127our $DB_ENV;
105 128
129our @EXTRA_MODULES = qw(pod match mapscript);
130
106our %CFG; 131our %CFG;
107 132
108our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
109our $RUNTIME; 134our $RUNTIME;
110our $NOW; 135our $NOW;
… …
119our $LOAD; # a number between 0 (idle) and 1 (too many objects) 144our $LOAD; # a number between 0 (idle) and 1 (too many objects)
120our $LOADAVG; # same thing, but with alpha-smoothing 145our $LOADAVG; # same thing, but with alpha-smoothing
121our $JITTER; # average jitter 146our $JITTER; # average jitter
122our $TICK_START; # for load detecting purposes 147our $TICK_START; # for load detecting purposes
123 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
124binmode STDOUT; 154binmode STDOUT;
125binmode STDERR; 155binmode STDERR;
126 156
127# read virtual server time, if available 157# read virtual server time, if available
128unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 158unless ($RUNTIME || !-e $RUNTIMEFILE) {
129 open my $fh, "<", "$LOCALDIR/runtime" 159 open my $fh, "<", $RUNTIMEFILE
130 or die "unable to read runtime file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
131 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
132} 162}
163
164eval "sub TICK() { $TICK } 1" or die;
133 165
134mkdir $_ 166mkdir $_
135 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
136 168
137our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
138 170
139sub 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::"} };
140 187
141############################################################################# 188#############################################################################
142 189
143=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
144 191
… …
191returns 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
192per 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.
193 240
194=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
195 242
196This array contains the results of the last C<invoke ()> call. When 243This array contains the results of the last C<invoke ()> call. When
197C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 244C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
198that call. 245that call.
199 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
200=back 253=back
201 254
202=cut 255=cut
203 256
204BEGIN { 257sub error(@) { LOG llevError, join "", @_ }
205 *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 {
206 my $msg = join "", @_; 264 my $msg = join "", @_;
207 265
208 $msg .= "\n" 266 $msg .= "\n"
209 unless $msg =~ /\n$/; 267 unless $msg =~ /\n$/;
210 268
211 $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;
212 270
213 LOG llevError, $msg; 271 LOG llevWarn, $msg;
214 }; 272};
215}
216 273
217$Coro::State::DIEHOOK = sub { 274$Coro::State::DIEHOOK = sub {
218 return unless $^S eq 0; # "eq", not "==" 275 return unless $^S eq 0; # "eq", not "=="
219 276
220 if ($Coro::current == $Coro::main) {#d# 277 error Carp::longmess $_[0];
278
279 if (in_main) {#d#
221 warn "DIEHOOK called in main context, Coro bug?\n";#d# 280 error "DIEHOOK called in main context, Coro bug?\n";#d#
222 return;#d# 281 return;#d#
223 }#d# 282 }#d#
224 283
225 # kill coroutine otherwise 284 # kill coroutine otherwise
226 warn Carp::longmess $_[0];
227 Coro::terminate 285 Coro::terminate
228}; 286};
229
230$SIG{__DIE__} = sub { }; #d#?
231 287
232@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 288@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
233@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 289@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
234@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 290@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
235@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 291@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
242for my $pkg (qw( 298for my $pkg (qw(
243 cf::global cf::attachable 299 cf::global cf::attachable
244 cf::object cf::object::player 300 cf::object cf::object::player
245 cf::client cf::player 301 cf::client cf::player
246 cf::arch cf::living 302 cf::arch cf::living
303 cf::map cf::mapspace
247 cf::map cf::party cf::region 304 cf::party cf::region
248)) { 305)) {
249 no strict 'refs';
250 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 306 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
251} 307}
252 308
253$EV::DIED = sub { 309$EV::DIED = sub {
254 warn "error in event callback: @_"; 310 Carp::cluck "error in event callback: @_";
255}; 311};
256 312
257############################################################################# 313#############################################################################
258 314
259=head2 UTILITY FUNCTIONS 315=head2 UTILITY FUNCTIONS
… …
296our $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
297 353
298sub encode_json($) { $json_coder->encode ($_[0]) } 354sub encode_json($) { $json_coder->encode ($_[0]) }
299sub decode_json($) { $json_coder->decode ($_[0]) } 355sub decode_json($) { $json_coder->decode ($_[0]) }
300 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
301=item cf::lock_wait $string 371=item cf::lock_wait $string
302 372
303Wait until the given lock is available. See cf::lock_acquire. 373Wait until the given lock is available. See cf::lock_acquire.
304 374
305=item my $lock = cf::lock_acquire $string 375=item my $lock = cf::lock_acquire $string
306 376
307Wait 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
308a 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,
309for example when the coroutine gets canceled), the lock is automatically 379for example when the coroutine gets canceled), the lock is automatically
310returned. 380returned.
311 381
312Locks 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
313deadlocked coro. 383deadlocked coro.
… …
319 389
320Return 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.
321 391
322=cut 392=cut
323 393
324our %LOCK; 394our $LOCKS = new Coro::SemaphoreSet;
325our %LOCKER;#d#
326 395
327sub lock_wait($) { 396sub lock_wait($) {
328 my ($key) = @_; 397 $LOCKS->wait ($_[0]);
329
330 if ($LOCKER{$key} == $Coro::current) {#d#
331 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
332 return;#d#
333 }#d#
334
335 # wait for lock, if any
336 while ($LOCK{$key}) {
337 push @{ $LOCK{$key} }, $Coro::current;
338 Coro::schedule;
339 }
340} 398}
341 399
342sub lock_acquire($) { 400sub lock_acquire($) {
343 my ($key) = @_; 401 $LOCKS->guard ($_[0])
344
345 # wait, to be sure we are not locked
346 lock_wait $key;
347
348 $LOCK{$key} = [];
349 $LOCKER{$key} = $Coro::current;#d#
350
351 Coro::guard {
352 delete $LOCKER{$key};#d#
353 # wake up all waiters, to be on the safe side
354 $_->ready for @{ delete $LOCK{$key} };
355 }
356} 402}
357 403
358sub lock_active($) { 404sub lock_active($) {
359 my ($key) = @_; 405 $LOCKS->count ($_[0]) < 1
360
361 ! ! $LOCK{$key}
362} 406}
363 407
364sub freeze_mainloop { 408sub freeze_mainloop {
365 tick_inhibit_inc; 409 tick_inhibit_inc;
366 410
367 Coro::guard \&tick_inhibit_dec; 411 &Guard::guard (\&tick_inhibit_dec);
368} 412}
369 413
370=item cf::periodic $interval, $cb 414=item cf::periodic $interval, $cb
371 415
372Like 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
373get spread over timer. 417get spread over time.
374 418
375=cut 419=cut
376 420
377sub periodic($$) { 421sub periodic($$) {
378 my ($interval, $cb) = @_; 422 my ($interval, $cb) = @_;
… …
395 439
396=cut 440=cut
397 441
398our @SLOT_QUEUE; 442our @SLOT_QUEUE;
399our $SLOT_QUEUE; 443our $SLOT_QUEUE;
444our $SLOT_DECAY = 0.9;
400 445
401$SLOT_QUEUE->cancel if $SLOT_QUEUE; 446$SLOT_QUEUE->cancel if $SLOT_QUEUE;
402$SLOT_QUEUE = Coro::async { 447$SLOT_QUEUE = Coro::async {
403 $Coro::current->desc ("timeslot manager"); 448 $Coro::current->desc ("timeslot manager");
404 449
405 my $signal = new Coro::Signal; 450 my $signal = new Coro::Signal;
451 my $busy;
406 452
407 while () { 453 while () {
408 next_job: 454 next_job:
455
409 my $avail = cf::till_tick; 456 my $avail = cf::till_tick;
410 if ($avail > 0.01) { 457
411 for (0 .. $#SLOT_QUEUE) { 458 for (0 .. $#SLOT_QUEUE) {
412 if ($SLOT_QUEUE[$_][0] < $avail) { 459 if ($SLOT_QUEUE[$_][0] <= $avail) {
460 $busy = 0;
413 my $job = splice @SLOT_QUEUE, $_, 1, (); 461 my $job = splice @SLOT_QUEUE, $_, 1, ();
414 $job->[2]->send; 462 $job->[2]->send;
415 Coro::cede; 463 Coro::cede;
416 goto next_job; 464 goto next_job;
417 } 465 } else {
466 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
418 } 467 }
419 } 468 }
420 469
421 if (@SLOT_QUEUE) { 470 if (@SLOT_QUEUE) {
422 # 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
423 push @cf::WAIT_FOR_TICK, $signal; 472 push @cf::WAIT_FOR_TICK, $signal;
424 $signal->wait; 473 $signal->wait;
425 } else { 474 } else {
475 $busy = 0;
426 Coro::schedule; 476 Coro::schedule;
427 } 477 }
428 } 478 }
429}; 479};
430 480
431sub get_slot($;$$) { 481sub get_slot($;$$) {
432 return if tick_inhibit || $Coro::current == $Coro::main; 482 return if tick_inhibit || $Coro::current == $Coro::main;
433 483
434 my ($time, $pri, $name) = @_; 484 my ($time, $pri, $name) = @_;
435 485
436 $time = $TICK * .6 if $time > $TICK * .6; 486 $time = clamp $time, 0.01, $TICK * .6;
487
437 my $sig = new Coro::Signal; 488 my $sig = new Coro::Signal;
438 489
439 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 490 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
440 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 491 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
441 $SLOT_QUEUE->ready; 492 $SLOT_QUEUE->ready;
… …
468 519
469sub sync_job(&) { 520sub sync_job(&) {
470 my ($job) = @_; 521 my ($job) = @_;
471 522
472 if ($Coro::current == $Coro::main) { 523 if ($Coro::current == $Coro::main) {
473 my $time = EV::time; 524 my $time = AE::time;
474 525
475 # this is the main coro, too bad, we have to block 526 # this is the main coro, too bad, we have to block
476 # till the operation succeeds, freezing the server :/ 527 # till the operation succeeds, freezing the server :/
477 528
478 LOG llevError, Carp::longmess "sync job";#d# 529 LOG llevError, Carp::longmess "sync job";#d#
… …
483 my @res; 534 my @res;
484 535
485 (async { 536 (async {
486 $Coro::current->desc ("sync job coro"); 537 $Coro::current->desc ("sync job coro");
487 @res = eval { $job->() }; 538 @res = eval { $job->() };
488 warn $@ if $@; 539 error $@ if $@;
489 undef $busy; 540 undef $busy;
490 })->prio (Coro::PRIO_MAX); 541 })->prio (Coro::PRIO_MAX);
491 542
492 while ($busy) { 543 while ($busy) {
493 if (Coro::nready) { 544 if (Coro::nready) {
… …
495 } else { 546 } else {
496 EV::loop EV::LOOP_ONESHOT; 547 EV::loop EV::LOOP_ONESHOT;
497 } 548 }
498 } 549 }
499 550
500 my $time = EV::time - $time; 551 my $time = AE::time - $time;
501 552
502 $TICK_START += $time; # do not account sync jobs to server load 553 $TICK_START += $time; # do not account sync jobs to server load
503 554
504 wantarray ? @res : $res[0] 555 wantarray ? @res : $res[0]
505 } else { 556 } else {
… …
549 reset_signals; 600 reset_signals;
550 &$cb 601 &$cb
551 }, @args; 602 }, @args;
552 603
553 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 )
554} 616}
555 617
556=item $coin = coin_from_name $name 618=item $coin = coin_from_name $name
557 619
558=cut 620=cut
… …
693 755
694 my $t1 = Time::HiRes::time; 756 my $t1 = Time::HiRes::time;
695 my $data = $process->(\@data); 757 my $data = $process->(\@data);
696 my $t2 = Time::HiRes::time; 758 my $t2 = Time::HiRes::time;
697 759
698 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 760 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
699 761
700 db_put cache => "$id/data", $data; 762 db_put cache => "$id/data", $data;
701 db_put cache => "$id/md5" , $md5; 763 db_put cache => "$id/md5" , $md5;
702 db_put cache => "$id/meta", $meta; 764 db_put cache => "$id/meta", $meta;
703 765
… …
713 775
714=cut 776=cut
715 777
716sub datalog($@) { 778sub datalog($@) {
717 my ($type, %kv) = @_; 779 my ($type, %kv) = @_;
718 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 780 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
719} 781}
720 782
721=back 783=back
722 784
723=cut 785=cut
724 786
725############################################################################# 787#############################################################################
726 788
727=head2 ATTACHABLE OBJECTS 789=head2 ATTACHABLE OBJECTS
728 790
729Many objects in crossfire are so-called attachable objects. That means you can 791Many objects in deliantra are so-called attachable objects. That means you can
730attach callbacks/event handlers (a collection of which is called an "attachment") 792attach callbacks/event handlers (a collection of which is called an "attachment")
731to it. All such attachable objects support the following methods. 793to it. All such attachable objects support the following methods.
732 794
733In the following description, CLASS can be any of C<global>, C<object> 795In the following description, CLASS can be any of C<global>, C<object>
734C<player>, C<client> or C<map> (i.e. the attachable objects in 796C<player>, C<client> or C<map> (i.e. the attachable objects in
… …
784=item cf::CLASS::attachment $name, ... 846=item cf::CLASS::attachment $name, ...
785 847
786Register an attachment by C<$name> through which attachable objects of the 848Register an attachment by C<$name> through which attachable objects of the
787given CLASS can refer to this attachment. 849given CLASS can refer to this attachment.
788 850
789Some classes such as crossfire maps and objects can specify attachments 851Some classes such as deliantra maps and objects can specify attachments
790that are attached at load/instantiate time, thus the need for a name. 852that are attached at load/instantiate time, thus the need for a name.
791 853
792These calls expect any number of the following handler/hook descriptions: 854These calls expect any number of the following handler/hook descriptions:
793 855
794=over 4 856=over 4
… …
918 980
919 } elsif (exists $cb_id{$type}) { 981 } elsif (exists $cb_id{$type}) {
920 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 982 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
921 983
922 } elsif (ref $type) { 984 } elsif (ref $type) {
923 warn "attaching objects not supported, ignoring.\n"; 985 error "attaching objects not supported, ignoring.\n";
924 986
925 } else { 987 } else {
926 shift @arg; 988 shift @arg;
927 warn "attach argument '$type' not supported, ignoring.\n"; 989 error "attach argument '$type' not supported, ignoring.\n";
928 } 990 }
929 } 991 }
930} 992}
931 993
932sub _object_attach { 994sub _object_attach {
… …
942 _attach $registry, $klass, @attach; 1004 _attach $registry, $klass, @attach;
943 } 1005 }
944 1006
945 $obj->{$name} = \%arg; 1007 $obj->{$name} = \%arg;
946 } else { 1008 } else {
947 warn "object uses attachment '$name' which is not available, postponing.\n"; 1009 info "object uses attachment '$name' which is not available, postponing.\n";
948 } 1010 }
949 1011
950 $obj->{_attachment}{$name} = undef; 1012 $obj->{_attachment}{$name} = undef;
951} 1013}
952 1014
… …
1011 1073
1012 for (@$callbacks) { 1074 for (@$callbacks) {
1013 eval { &{$_->[1]} }; 1075 eval { &{$_->[1]} };
1014 1076
1015 if ($@) { 1077 if ($@) {
1016 warn "$@";
1017 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1078 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1018 override; 1079 override;
1019 } 1080 }
1020 1081
1021 return 1 if $override; 1082 return 1 if $override;
1022 } 1083 }
… …
1085 1146
1086sub reattach { 1147sub reattach {
1087 # basically do the same as instantiate, without calling instantiate 1148 # basically do the same as instantiate, without calling instantiate
1088 my ($obj) = @_; 1149 my ($obj) = @_;
1089 1150
1151 # no longer needed after getting rid of delete_package?
1090 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1152 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1091 1153
1092 my $registry = $obj->registry; 1154 my $registry = $obj->registry;
1093 1155
1094 @$registry = (); 1156 @$registry = ();
1095 1157
… …
1100 for (@$attach) { 1162 for (@$attach) {
1101 my ($klass, @attach) = @$_; 1163 my ($klass, @attach) = @$_;
1102 _attach $registry, $klass, @attach; 1164 _attach $registry, $klass, @attach;
1103 } 1165 }
1104 } else { 1166 } else {
1105 warn "object uses attachment '$name' that is not available, postponing.\n"; 1167 info "object uses attachment '$name' that is not available, postponing.\n";
1106 } 1168 }
1107 } 1169 }
1108} 1170}
1109 1171
1110cf::attachable->attach ( 1172cf::attachable->attach (
… …
1137 my ($filename, $rdata, $objs) = @_; 1199 my ($filename, $rdata, $objs) = @_;
1138 1200
1139 sync_job { 1201 sync_job {
1140 if (length $$rdata) { 1202 if (length $$rdata) {
1141 utf8::decode (my $decname = $filename); 1203 utf8::decode (my $decname = $filename);
1142 warn sprintf "saving %s (%d,%d)\n", 1204 trace sprintf "saving %s (%d,%d)\n",
1143 $decname, length $$rdata, scalar @$objs; 1205 $decname, length $$rdata, scalar @$objs
1206 if $VERBOSE_IO;
1144 1207
1145 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1208 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1146 chmod SAVE_MODE, $fh; 1209 aio_chmod $fh, SAVE_MODE;
1147 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1210 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1148 aio_fsync $fh if $cf::USE_FSYNC; 1211 if ($cf::USE_FSYNC) {
1212 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;
1213 aio_fsync $fh;
1214 }
1149 close $fh; 1215 aio_close $fh;
1150 1216
1151 if (@$objs) { 1217 if (@$objs) {
1152 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1218 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1153 chmod SAVE_MODE, $fh; 1219 aio_chmod $fh, SAVE_MODE;
1154 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1220 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1155 aio_write $fh, 0, (length $data), $data, 0; 1221 aio_write $fh, 0, (length $data), $data, 0;
1156 aio_fsync $fh if $cf::USE_FSYNC; 1222 if ($cf::USE_FSYNC) {
1223 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;
1224 aio_fsync $fh;
1225 }
1157 close $fh; 1226 aio_close $fh;
1158 aio_rename "$filename.pst~", "$filename.pst"; 1227 aio_rename "$filename.pst~", "$filename.pst";
1159 } 1228 }
1160 } else { 1229 } else {
1161 aio_unlink "$filename.pst"; 1230 aio_unlink "$filename.pst";
1162 } 1231 }
1163 1232
1164 aio_rename "$filename~", $filename; 1233 aio_rename "$filename~", $filename;
1234
1235 $filename =~ s%/[^/]+$%%;
1236 aio_pathsync $filename if $cf::USE_FSYNC;
1165 } else { 1237 } else {
1166 warn "FATAL: $filename~: $!\n"; 1238 error "unable to save objects: $filename~: $!\n";
1167 } 1239 }
1168 } else { 1240 } else {
1169 aio_unlink $filename; 1241 aio_unlink $filename;
1170 aio_unlink "$filename.pst"; 1242 aio_unlink "$filename.pst";
1171 } 1243 }
… …
1195 my $st = eval { Coro::Storable::thaw $av }; 1267 my $st = eval { Coro::Storable::thaw $av };
1196 $av = $st->{objs}; 1268 $av = $st->{objs};
1197 } 1269 }
1198 1270
1199 utf8::decode (my $decname = $filename); 1271 utf8::decode (my $decname = $filename);
1200 warn sprintf "loading %s (%d,%d)\n", 1272 trace sprintf "loading %s (%d,%d)\n",
1201 $decname, length $data, scalar @{$av || []}; 1273 $decname, length $data, scalar @{$av || []}
1274 if $VERBOSE_IO;
1202 1275
1203 ($data, $av) 1276 ($data, $av)
1204} 1277}
1205 1278
1206=head2 COMMAND CALLBACKS 1279=head2 COMMAND CALLBACKS
… …
1262 my ($name, $cb) = @_; 1335 my ($name, $cb) = @_;
1263 1336
1264 $EXTICMD{$name} = $cb; 1337 $EXTICMD{$name} = $cb;
1265} 1338}
1266 1339
1340use File::Glob ();
1341
1267cf::player->attach ( 1342cf::player->attach (
1268 on_command => sub { 1343 on_unknown_command => sub {
1269 my ($pl, $name, $params) = @_; 1344 my ($pl, $name, $params) = @_;
1270 1345
1271 my $cb = $COMMAND{$name} 1346 my $cb = $COMMAND{$name}
1272 or return; 1347 or return;
1273 1348
… …
1296 1371
1297 $pl->ext_reply ($reply, @reply) 1372 $pl->ext_reply ($reply, @reply)
1298 if $reply; 1373 if $reply;
1299 1374
1300 } else { 1375 } else {
1301 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1376 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1302 } 1377 }
1303 1378
1304 cf::override; 1379 cf::override;
1305 }, 1380 },
1306); 1381);
1307 1382
1383# "readahead" all extensions
1384sub cache_extensions {
1385 my $grp = IO::AIO::aio_group;
1386
1387 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1388 for (grep /\.ext$/, @{$_[0]}) {
1389 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1390 }
1391 };
1392
1393 $grp
1394}
1395
1308sub load_extensions { 1396sub load_extensions {
1397 info "loading extensions...";
1398
1309 cf::sync_job { 1399 cf::sync_job {
1310 my %todo; 1400 my %todo;
1311 1401
1312 for my $path (<$LIBDIR/*.ext>) { 1402 for my $path (<$LIBDIR/*.ext>) {
1313 next unless -r $path; 1403 next unless -r $path;
… …
1331 1421
1332 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1422 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1333 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1423 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1334 1424
1335 $ext{source} = 1425 $ext{source} =
1336 "package $pkg; use strict; use utf8;\n" 1426 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1337 . "#line 1 \"$path\"\n{\n" 1427 . "#line 1 \"$path\"\n{\n"
1338 . $source 1428 . $source
1339 . "\n};\n1"; 1429 . "\n};\n1";
1340 1430
1341 $todo{$base} = \%ext; 1431 $todo{$base} = \%ext;
1342 } 1432 }
1343 1433
1434 my $pass = 0;
1344 my %done; 1435 my %done;
1345 while (%todo) { 1436 while (%todo) {
1346 my $progress; 1437 my $progress;
1347 1438
1439 ++$pass;
1440
1441 ext:
1348 while (my ($k, $v) = each %todo) { 1442 while (my ($k, $v) = each %todo) {
1349 for (split /,\s*/, $v->{meta}{depends}) { 1443 for (split /,\s*/, $v->{meta}{depends}) {
1350 goto skip 1444 next ext
1351 unless exists $done{$_}; 1445 unless exists $done{$_};
1352 } 1446 }
1353 1447
1354 warn "... loading '$k' into '$v->{pkg}'\n"; 1448 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1355 1449
1356 unless (eval $v->{source}) { 1450 my $active = eval $v->{source};
1451
1452 if (length $@) {
1357 my $msg = $@ ? "$v->{path}: $@\n" 1453 error "$v->{path}: $@\n";
1358 : "$v->{base}: extension inactive.\n";
1359 1454
1360 if (exists $v->{meta}{mandatory}) {
1361 warn $msg;
1362 cf::cleanup "mandatory extension failed to load, exiting."; 1455 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1363 } 1456 if exists $v->{meta}{mandatory};
1364 1457
1365 warn $msg; 1458 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1459 delete $todo{$k};
1460 } else {
1461 $done{$k} = delete $todo{$k};
1462 push @EXTS, $v->{pkg};
1463 $progress = 1;
1464
1465 info "$v->{base}: extension inactive.\n"
1466 unless $active;
1366 } 1467 }
1367
1368 $done{$k} = delete $todo{$k};
1369 push @EXTS, $v->{pkg};
1370 $progress = 1;
1371 } 1468 }
1372 1469
1373 skip: 1470 unless ($progress) {
1374 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1471 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1375 unless $progress; 1472
1473 while (my ($k, $v) = each %todo) {
1474 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1475 if exists $v->{meta}{mandatory};
1476 }
1477 }
1376 } 1478 }
1377 }; 1479 };
1378} 1480}
1379 1481
1380############################################################################# 1482#############################################################################
1381 1483
1382=back 1484=back
1383 1485
1384=head2 CORE EXTENSIONS 1486=head2 CORE EXTENSIONS
1385 1487
1386Functions and methods that extend core crossfire objects. 1488Functions and methods that extend core deliantra objects.
1387 1489
1388=cut 1490=cut
1389 1491
1390package cf::player; 1492package cf::player;
1391 1493
… …
1434 1536
1435sub exists($) { 1537sub exists($) {
1436 my ($login) = @_; 1538 my ($login) = @_;
1437 1539
1438 $cf::PLAYER{$login} 1540 $cf::PLAYER{$login}
1439 or cf::sync_job { !aio_stat path $login } 1541 or !aio_stat path $login
1440} 1542}
1441 1543
1442sub find($) { 1544sub find($) {
1443 return $cf::PLAYER{$_[0]} || do { 1545 return $cf::PLAYER{$_[0]} || do {
1444 my $login = $_[0]; 1546 my $login = $_[0];
… …
1456 my $f = new_from_file cf::object::thawer path $login 1558 my $f = new_from_file cf::object::thawer path $login
1457 or return; 1559 or return;
1458 1560
1459 my $pl = cf::player::load_pl $f 1561 my $pl = cf::player::load_pl $f
1460 or return; 1562 or return;
1563
1461 local $cf::PLAYER_LOADING{$login} = $pl; 1564 local $cf::PLAYER_LOADING{$login} = $pl;
1462 $f->resolve_delayed_derefs; 1565 $f->resolve_delayed_derefs;
1463 $cf::PLAYER{$login} = $pl 1566 $cf::PLAYER{$login} = $pl
1464 } 1567 }
1465 } 1568 }
1466} 1569}
1467 1570
1571cf::player->attach (
1572 on_load => sub {
1573 my ($pl, $path) = @_;
1574
1575 # restore slots saved in save, below
1576 my $slots = delete $pl->{_slots};
1577
1578 $pl->ob->current_weapon ($slots->[0]);
1579 $pl->combat_ob ($slots->[1]);
1580 $pl->ranged_ob ($slots->[2]);
1581 },
1582);
1583
1468sub save($) { 1584sub save($) {
1469 my ($pl) = @_; 1585 my ($pl) = @_;
1470 1586
1471 return if $pl->{deny_save}; 1587 return if $pl->{deny_save};
1472 1588
… …
1477 1593
1478 aio_mkdir playerdir $pl, 0770; 1594 aio_mkdir playerdir $pl, 0770;
1479 $pl->{last_save} = $cf::RUNTIME; 1595 $pl->{last_save} = $cf::RUNTIME;
1480 1596
1481 cf::get_slot 0.01; 1597 cf::get_slot 0.01;
1598
1599 # save slots, to be restored later
1600 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1482 1601
1483 $pl->save_pl ($path); 1602 $pl->save_pl ($path);
1484 cf::cede_to_tick; 1603 cf::cede_to_tick;
1485} 1604}
1486 1605
… …
1518 my ($pl) = @_; 1637 my ($pl) = @_;
1519 1638
1520 my $name = $pl->ob->name; 1639 my $name = $pl->ob->name;
1521 1640
1522 $pl->{deny_save} = 1; 1641 $pl->{deny_save} = 1;
1523 $pl->password ("*"); # this should lock out the player until we nuked the dir 1642 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1524 1643
1525 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1644 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1526 $pl->deactivate; 1645 $pl->deactivate;
1646 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1527 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1647 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1528 $pl->ns->destroy if $pl->ns; 1648 $pl->ns->destroy if $pl->ns;
1529 1649
1530 my $path = playerdir $pl; 1650 my $path = playerdir $pl;
1531 my $temp = "$path~$cf::RUNTIME~deleting~"; 1651 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1570 1690
1571 for my $login (@$dirs) { 1691 for my $login (@$dirs) {
1572 my $path = path $login; 1692 my $path = path $login;
1573 1693
1574 # a .pst is a dead give-away for a valid player 1694 # a .pst is a dead give-away for a valid player
1575 unless (-e "$path.pst") { 1695 # if no pst file found, open and chekc for blocked users
1696 if (aio_stat "$path.pst") {
1576 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1697 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1577 aio_read $fh, 0, 512, my $buf, 0 or next; 1698 aio_read $fh, 0, 512, my $buf, 0 or next;
1578 $buf !~ /^password -------------$/m or next; # official not-valid tag 1699 $buf !~ /^password -------------$/m or next; # official not-valid tag
1579 } 1700 }
1580 1701
… …
1584 1705
1585 \@logins 1706 \@logins
1586} 1707}
1587 1708
1588=item $player->maps 1709=item $player->maps
1710
1711=item cf::player::maps $login
1589 1712
1590Returns an arrayref of map paths that are private for this 1713Returns an arrayref of map paths that are private for this
1591player. May block. 1714player. May block.
1592 1715
1593=cut 1716=cut
… …
1611 } 1734 }
1612 1735
1613 \@paths 1736 \@paths
1614} 1737}
1615 1738
1616=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1739=item $protocol_xml = $player->expand_cfpod ($cfpod)
1617 1740
1618Expand crossfire pod fragments into protocol xml. 1741Expand deliantra pod fragments into protocol xml.
1619
1620=cut
1621
1622use re 'eval';
1623
1624my $group;
1625my $interior; $interior = qr{
1626 # match a pod interior sequence sans C<< >>
1627 (?:
1628 \ (.*?)\ (?{ $group = $^N })
1629 | < (??{$interior}) >
1630 )
1631}x;
1632
1633sub expand_cfpod {
1634 my ($self, $pod) = @_;
1635
1636 my $xml;
1637
1638 while () {
1639 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1640 $group = $1;
1641
1642 $group =~ s/&/&amp;/g;
1643 $group =~ s/</&lt;/g;
1644
1645 $xml .= $group;
1646 } elsif ($pod =~ m%\G
1647 ([BCGHITU])
1648 <
1649 (?:
1650 ([^<>]*) (?{ $group = $^N })
1651 | < $interior >
1652 )
1653 >
1654 %gcsx
1655 ) {
1656 my ($code, $data) = ($1, $group);
1657
1658 if ($code eq "B") {
1659 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1660 } elsif ($code eq "I") {
1661 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1662 } elsif ($code eq "U") {
1663 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1664 } elsif ($code eq "C") {
1665 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1666 } elsif ($code eq "T") {
1667 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1668 } elsif ($code eq "G") {
1669 my ($male, $female) = split /\|/, $data;
1670 $data = $self->gender ? $female : $male;
1671 $xml .= expand_cfpod ($self, $data);
1672 } elsif ($code eq "H") {
1673 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1674 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1675 "")
1676 [$self->{hintmode}];
1677 } else {
1678 $xml .= "error processing '$code($data)' directive";
1679 }
1680 } else {
1681 if ($pod =~ /\G(.+)/) {
1682 warn "parse error while expanding $pod (at $1)";
1683 }
1684 last;
1685 }
1686 }
1687
1688 for ($xml) {
1689 # create single paragraphs (very hackish)
1690 s/(?<=\S)\n(?=\w)/ /g;
1691
1692 # compress some whitespace
1693 s/\s+\n/\n/g; # ws line-ends
1694 s/\n\n+/\n/g; # double lines
1695 s/^\n+//; # beginning lines
1696 s/\n+$//; # ending lines
1697 }
1698
1699 $xml
1700}
1701
1702no re 'eval';
1703
1704sub hintmode {
1705 $_[0]{hintmode} = $_[1] if @_ > 1;
1706 $_[0]{hintmode}
1707}
1708 1742
1709=item $player->ext_reply ($msgid, @msg) 1743=item $player->ext_reply ($msgid, @msg)
1710 1744
1711Sends an ext reply to the player. 1745Sends an ext reply to the player.
1712 1746
… …
1744 1778
1745=cut 1779=cut
1746 1780
1747sub find_by_path($) { 1781sub find_by_path($) {
1748 my ($path) = @_; 1782 my ($path) = @_;
1783
1784 $path =~ s/^~[^\/]*//; # skip ~login
1749 1785
1750 my ($match, $specificity); 1786 my ($match, $specificity);
1751 1787
1752 for my $region (list) { 1788 for my $region (list) {
1753 if ($region->{match} && $path =~ $region->{match}) { 1789 if ($region->{match} && $path =~ $region->{match}) {
… …
1785 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1821 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1786 1822
1787 # mit "rum" bekleckern, nicht 1823 # mit "rum" bekleckern, nicht
1788 $self->_create_random_map ( 1824 $self->_create_random_map (
1789 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1825 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1790 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1826 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1791 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1827 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1792 $rmp->{exit_on_final_map}, 1828 $rmp->{exit_on_final_map},
1793 $rmp->{xsize}, $rmp->{ysize}, 1829 $rmp->{xsize}, $rmp->{ysize},
1794 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1830 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1795 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1831 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1817 1853
1818 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1854 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1819} 1855}
1820 1856
1821# also paths starting with '/' 1857# also paths starting with '/'
1822$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1858$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1823 1859
1824sub thawer_merge { 1860sub thawer_merge {
1825 my ($self, $merge) = @_; 1861 my ($self, $merge) = @_;
1826 1862
1827 # we have to keep some variables in memory intact 1863 # we have to keep some variables in memory intact
… …
1925 1961
1926 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1962 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1927 "$UNIQUEDIR/$path" 1963 "$UNIQUEDIR/$path"
1928} 1964}
1929 1965
1930# and all this just because we cannot iterate over
1931# all maps in C++...
1932sub change_all_map_light {
1933 my ($change) = @_;
1934
1935 $_->change_map_light ($change)
1936 for grep $_->outdoor, values %cf::MAP;
1937}
1938
1939sub decay_objects { 1966sub decay_objects {
1940 my ($self) = @_; 1967 my ($self) = @_;
1941 1968
1942 return if $self->{deny_reset}; 1969 return if $self->{deny_reset};
1943 1970
… …
2025sub find { 2052sub find {
2026 my ($path, $origin) = @_; 2053 my ($path, $origin) = @_;
2027 2054
2028 $path = normalise $path, $origin && $origin->path; 2055 $path = normalise $path, $origin && $origin->path;
2029 2056
2030 cf::lock_wait "map_data:$path";#d#remove 2057 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2031 cf::lock_wait "map_find:$path"; 2058 my $guard2 = cf::lock_acquire "map_find:$path";
2032 2059
2033 $cf::MAP{$path} || do { 2060 $cf::MAP{$path} || do {
2034 my $guard1 = cf::lock_acquire "map_find:$path";
2035 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2036
2037 my $map = new_from_path cf::map $path 2061 my $map = new_from_path cf::map $path
2038 or return; 2062 or return;
2039 2063
2040 $map->{last_save} = $cf::RUNTIME; 2064 $map->{last_save} = $cf::RUNTIME;
2041 2065
… …
2043 or return; 2067 or return;
2044 2068
2045 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2069 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2046 # doing this can freeze the server in a sync job, obviously 2070 # doing this can freeze the server in a sync job, obviously
2047 #$cf::WAIT_FOR_TICK->wait; 2071 #$cf::WAIT_FOR_TICK->wait;
2072 undef $guard2;
2048 undef $guard1; 2073 undef $guard1;
2049 undef $guard2;
2050 $map->reset; 2074 $map->reset;
2051 return find $path; 2075 return find $path;
2052 } 2076 }
2053 2077
2054 $cf::MAP{$path} = $map 2078 $cf::MAP{$path} = $map
2055 } 2079 }
2056} 2080}
2057 2081
2058sub pre_load { } 2082sub pre_load { }
2059sub post_load { } 2083#sub post_load { } # XS
2060 2084
2061sub load { 2085sub load {
2062 my ($self) = @_; 2086 my ($self) = @_;
2063 2087
2064 local $self->{deny_reset} = 1; # loading can take a long time 2088 local $self->{deny_reset} = 1; # loading can take a long time
… …
2081 my $f = new_from_file cf::object::thawer $self->{load_path}; 2105 my $f = new_from_file cf::object::thawer $self->{load_path};
2082 $f->skip_block; 2106 $f->skip_block;
2083 $self->_load_objects ($f) 2107 $self->_load_objects ($f)
2084 or return; 2108 or return;
2085 2109
2086 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2110 $self->post_load_original
2087 if delete $self->{load_original}; 2111 if delete $self->{load_original};
2088 2112
2089 if (my $uniq = $self->uniq_path) { 2113 if (my $uniq = $self->uniq_path) {
2090 utf8::encode $uniq; 2114 utf8::encode $uniq;
2091 unless (aio_stat $uniq) { 2115 unless (aio_stat $uniq) {
… …
2109 unless ($self->{deny_activate}) { 2133 unless ($self->{deny_activate}) {
2110 $self->decay_objects; 2134 $self->decay_objects;
2111 $self->fix_auto_apply; 2135 $self->fix_auto_apply;
2112 $self->update_buttons; 2136 $self->update_buttons;
2113 cf::cede_to_tick; 2137 cf::cede_to_tick;
2114 $self->set_darkness_map;
2115 cf::cede_to_tick;
2116 $self->activate; 2138 $self->activate;
2117 } 2139 }
2118 2140
2119 $self->{last_save} = $cf::RUNTIME; 2141 $self->{last_save} = $cf::RUNTIME;
2120 $self->last_access ($cf::RUNTIME); 2142 $self->last_access ($cf::RUNTIME);
… …
2123 } 2145 }
2124 2146
2125 $self->post_load; 2147 $self->post_load;
2126} 2148}
2127 2149
2150# customize the map for a given player, i.e.
2151# return the _real_ map. used by e.g. per-player
2152# maps to change the path to ~playername/mappath
2128sub customise_for { 2153sub customise_for {
2129 my ($self, $ob) = @_; 2154 my ($self, $ob) = @_;
2130 2155
2131 return find "~" . $ob->name . "/" . $self->{path} 2156 return find "~" . $ob->name . "/" . $self->{path}
2132 if $self->per_player; 2157 if $self->per_player;
… …
2148 or next; 2173 or next;
2149 $neigh = find $neigh, $map 2174 $neigh = find $neigh, $map
2150 or next; 2175 or next;
2151 $neigh->load; 2176 $neigh->load;
2152 2177
2178 # now find the diagonal neighbours
2153 push @neigh, 2179 push @neigh,
2154 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2180 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2155 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2181 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2156 } 2182 }
2157 2183
… …
2209 $MAP_PREFETCHER->prio (6); 2235 $MAP_PREFETCHER->prio (6);
2210 2236
2211 () 2237 ()
2212} 2238}
2213 2239
2240# common code, used by both ->save and ->swapout
2214sub save { 2241sub _save {
2215 my ($self) = @_; 2242 my ($self) = @_;
2216
2217 my $lock = cf::lock_acquire "map_data:$self->{path}";
2218 2243
2219 $self->{last_save} = $cf::RUNTIME; 2244 $self->{last_save} = $cf::RUNTIME;
2220 2245
2221 return unless $self->dirty; 2246 return unless $self->dirty;
2222 2247
… …
2242 } else { 2267 } else {
2243 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2268 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2244 } 2269 }
2245} 2270}
2246 2271
2272sub save {
2273 my ($self) = @_;
2274
2275 my $lock = cf::lock_acquire "map_data:$self->{path}";
2276
2277 $self->_save;
2278}
2279
2247sub swap_out { 2280sub swap_out {
2248 my ($self) = @_; 2281 my ($self) = @_;
2249 2282
2250 # save first because save cedes
2251 $self->save;
2252
2253 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2283 my $lock = cf::lock_acquire "map_data:$self->{path}";
2254 2284
2255 return if $self->players;
2256 return if $self->in_memory != cf::MAP_ACTIVE; 2285 return if $self->in_memory != cf::MAP_ACTIVE;
2257 return if $self->{deny_save}; 2286 return if $self->{deny_save};
2287 return if $self->players;
2258 2288
2289 # first deactivate the map and "unlink" it from the core
2290 $self->deactivate;
2291 $_->clear_links_to ($self) for values %cf::MAP;
2259 $self->in_memory (cf::MAP_SWAPPED); 2292 $self->in_memory (cf::MAP_SWAPPED);
2293
2294 # then atomically save
2295 $self->_save;
2296
2297 # then free the map
2298 $self->clear;
2299}
2300
2301sub reset_at {
2302 my ($self) = @_;
2303
2304 # TODO: safety, remove and allow resettable per-player maps
2305 return 1e99 if $self->{deny_reset};
2306
2307 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2308 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2309
2310 $time + $to
2311}
2312
2313sub should_reset {
2314 my ($self) = @_;
2315
2316 $self->reset_at <= $cf::RUNTIME
2317}
2318
2319sub reset {
2320 my ($self) = @_;
2321
2322 my $lock = cf::lock_acquire "map_data:$self->{path}";
2323
2324 return if $self->players;
2325
2326 cf::trace "resetting map ", $self->path, "\n";
2327
2328 $self->in_memory (cf::MAP_SWAPPED);
2329
2330 # need to save uniques path
2331 unless ($self->{deny_save}) {
2332 my $uniq = $self->uniq_path; utf8::encode $uniq;
2333
2334 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2335 if $uniq;
2336 }
2337
2338 delete $cf::MAP{$self->path};
2260 2339
2261 $self->deactivate; 2340 $self->deactivate;
2262 $_->clear_links_to ($self) for values %cf::MAP; 2341 $_->clear_links_to ($self) for values %cf::MAP;
2263 $self->clear; 2342 $self->clear;
2264}
2265
2266sub reset_at {
2267 my ($self) = @_;
2268
2269 # TODO: safety, remove and allow resettable per-player maps
2270 return 1e99 if $self->{deny_reset};
2271
2272 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2273 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2274
2275 $time + $to
2276}
2277
2278sub should_reset {
2279 my ($self) = @_;
2280
2281 $self->reset_at <= $cf::RUNTIME
2282}
2283
2284sub reset {
2285 my ($self) = @_;
2286
2287 my $lock = cf::lock_acquire "map_data:$self->{path}";
2288
2289 return if $self->players;
2290
2291 warn "resetting map ", $self->path;
2292
2293 $self->in_memory (cf::MAP_SWAPPED);
2294
2295 # need to save uniques path
2296 unless ($self->{deny_save}) {
2297 my $uniq = $self->uniq_path; utf8::encode $uniq;
2298
2299 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2300 if $uniq;
2301 }
2302
2303 delete $cf::MAP{$self->path};
2304
2305 $self->deactivate;
2306 $_->clear_links_to ($self) for values %cf::MAP;
2307 $self->clear;
2308 2343
2309 $self->unlink_save; 2344 $self->unlink_save;
2310 $self->destroy; 2345 $self->destroy;
2311} 2346}
2312 2347
… …
2320 2355
2321 delete $cf::MAP{$self->path}; 2356 delete $cf::MAP{$self->path};
2322 2357
2323 $self->unlink_save; 2358 $self->unlink_save;
2324 2359
2325 bless $self, "cf::map"; 2360 bless $self, "cf::map::wrap";
2326 delete $self->{deny_reset}; 2361 delete $self->{deny_reset};
2327 $self->{deny_save} = 1; 2362 $self->{deny_save} = 1;
2328 $self->reset_timeout (1); 2363 $self->reset_timeout (1);
2329 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2364 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2330 2365
… …
2387 : normalise $_ 2422 : normalise $_
2388 } @{ aio_readdir $UNIQUEDIR or [] } 2423 } @{ aio_readdir $UNIQUEDIR or [] }
2389 ] 2424 ]
2390} 2425}
2391 2426
2427=item cf::map::static_maps
2428
2429Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2430file in the shared directory excluding F</styles> and F</editor>). May
2431block.
2432
2433=cut
2434
2435sub static_maps() {
2436 my @dirs = "";
2437 my @maps;
2438
2439 while (@dirs) {
2440 my $dir = shift @dirs;
2441
2442 next if $dir eq "/styles" || $dir eq "/editor";
2443
2444 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2445 or return;
2446
2447 for (@$files) {
2448 s/\.map$// or next;
2449 utf8::decode $_;
2450 push @maps, "$dir/$_";
2451 }
2452
2453 push @dirs, map "$dir/$_", @$dirs;
2454 }
2455
2456 \@maps
2457}
2458
2392=back 2459=back
2393 2460
2394=head3 cf::object 2461=head3 cf::object
2395 2462
2396=cut 2463=cut
… …
2457can be C<undef>. Does the right thing when the player is currently in a 2524can be C<undef>. Does the right thing when the player is currently in a
2458dialogue with the given NPC character. 2525dialogue with the given NPC character.
2459 2526
2460=cut 2527=cut
2461 2528
2529our $SAY_CHANNEL = {
2530 id => "say",
2531 title => "Map",
2532 reply => "say ",
2533 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2534};
2535
2536our $CHAT_CHANNEL = {
2537 id => "chat",
2538 title => "Chat",
2539 reply => "chat ",
2540 tooltip => "Player chat and shouts, global to the server.",
2541};
2542
2462# rough implementation of a future "reply" method that works 2543# rough implementation of a future "reply" method that works
2463# with dialog boxes. 2544# with dialog boxes.
2464#TODO: the first argument must go, split into a $npc->reply_to ( method 2545#TODO: the first argument must go, split into a $npc->reply_to ( method
2465sub cf::object::player::reply($$$;$) { 2546sub cf::object::player::reply($$$;$) {
2466 my ($self, $npc, $msg, $flags) = @_; 2547 my ($self, $npc, $msg, $flags) = @_;
… …
2477 my $dialog = $pl->{npc_dialog}; 2558 my $dialog = $pl->{npc_dialog};
2478 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2559 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2479 2560
2480 } else { 2561 } else {
2481 $msg = $npc->name . " says: $msg" if $npc; 2562 $msg = $npc->name . " says: $msg" if $npc;
2482 $self->message ($msg, $flags); 2563 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2483 } 2564 }
2484 } 2565 }
2485} 2566}
2486 2567
2487=item $object->send_msg ($channel, $msg, $color, [extra...]) 2568=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2512 2593
2513=item $player_object->enter_link 2594=item $player_object->enter_link
2514 2595
2515Freezes the player and moves him/her to a special map (C<{link}>). 2596Freezes the player and moves him/her to a special map (C<{link}>).
2516 2597
2517The player should be reasonably safe there for short amounts of time. You 2598The player should be reasonably safe there for short amounts of time (e.g.
2518I<MUST> call C<leave_link> as soon as possible, though. 2599for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2600though, as the player cannot control the character while it is on the link
2601map.
2519 2602
2520Will never block. 2603Will never block.
2521 2604
2522=item $player_object->leave_link ($map, $x, $y) 2605=item $player_object->leave_link ($map, $x, $y)
2523 2606
… …
2543sub cf::object::player::enter_link { 2626sub cf::object::player::enter_link {
2544 my ($self) = @_; 2627 my ($self) = @_;
2545 2628
2546 $self->deactivate_recursive; 2629 $self->deactivate_recursive;
2547 2630
2631 ++$self->{_link_recursion};
2632
2548 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2633 return if UNIVERSAL::isa $self->map, "ext::map_link";
2549 2634
2550 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2635 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2551 if $self->map && $self->map->{path} ne "{link}"; 2636 if $self->map && $self->map->{path} ne "{link}";
2552 2637
2553 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2638 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2554} 2639}
2555 2640
2556sub cf::object::player::leave_link { 2641sub cf::object::player::leave_link {
2557 my ($self, $map, $x, $y) = @_; 2642 my ($self, $map, $x, $y) = @_;
2558 2643
… …
2575 ($x, $y) = (-1, -1) 2660 ($x, $y) = (-1, -1)
2576 unless (defined $x) && (defined $y); 2661 unless (defined $x) && (defined $y);
2577 2662
2578 # use -1 or undef as default coordinates, not 0, 0 2663 # use -1 or undef as default coordinates, not 0, 0
2579 ($x, $y) = ($map->enter_x, $map->enter_y) 2664 ($x, $y) = ($map->enter_x, $map->enter_y)
2580 if $x <=0 && $y <= 0; 2665 if $x <= 0 && $y <= 0;
2581 2666
2582 $map->load; 2667 $map->load;
2583 $map->load_neighbours; 2668 $map->load_neighbours;
2584 2669
2585 return unless $self->contr->active; 2670 return unless $self->contr->active;
2586 $self->activate_recursive;
2587 2671
2588 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2672 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2589 $self->enter_map ($map, $x, $y); 2673 if ($self->enter_map ($map, $x, $y)) {
2590} 2674 # entering was successful
2675 delete $self->{_link_recursion};
2676 # only activate afterwards, to support waiting in hooks
2677 $self->activate_recursive;
2678 }
2591 2679
2680}
2681
2592=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2682=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2593 2683
2594Moves the player to the given map-path and coordinates by first freezing 2684Moves the player to the given map-path and coordinates by first freezing
2595her, loading and preparing them map, calling the provided $check callback 2685her, loading and preparing them map, calling the provided $check callback
2596that has to return the map if sucecssful, and then unfreezes the player on 2686that has to return the map if sucecssful, and then unfreezes the player on
2597the new (success) or old (failed) map position. In either case, $done will 2687the new (success) or old (failed) map position. In either case, $done will
2598be called at the end of this process. 2688be called at the end of this process.
2599 2689
2690Note that $check will be called with a potentially non-loaded map, so if
2691it needs a loaded map it has to call C<< ->load >>.
2692
2600=cut 2693=cut
2601 2694
2602our $GOTOGEN; 2695our $GOTOGEN;
2603 2696
2604sub cf::object::player::goto { 2697sub cf::object::player::goto {
2605 my ($self, $path, $x, $y, $check, $done) = @_; 2698 my ($self, $path, $x, $y, $check, $done) = @_;
2699
2700 if ($self->{_link_recursion} >= $MAX_LINKS) {
2701 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2702 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2703 ($path, $x, $y) = @$EMERGENCY_POSITION;
2704 }
2606 2705
2607 # do generation counting so two concurrent goto's will be executed in-order 2706 # do generation counting so two concurrent goto's will be executed in-order
2608 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2707 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2609 2708
2610 $self->enter_link; 2709 $self->enter_link;
… …
2634 my $map = eval { 2733 my $map = eval {
2635 my $map = defined $path ? cf::map::find $path : undef; 2734 my $map = defined $path ? cf::map::find $path : undef;
2636 2735
2637 if ($map) { 2736 if ($map) {
2638 $map = $map->customise_for ($self); 2737 $map = $map->customise_for ($self);
2639 $map = $check->($map) if $check && $map; 2738 $map = $check->($map, $x, $y, $self) if $check && $map;
2640 } else { 2739 } else {
2641 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2740 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2642 } 2741 }
2643 2742
2644 $map 2743 $map
… …
2652 if ($gen == $self->{_goto_generation}) { 2751 if ($gen == $self->{_goto_generation}) {
2653 delete $self->{_goto_generation}; 2752 delete $self->{_goto_generation};
2654 $self->leave_link ($map, $x, $y); 2753 $self->leave_link ($map, $x, $y);
2655 } 2754 }
2656 2755
2657 $done->() if $done; 2756 $done->($self) if $done;
2658 })->prio (1); 2757 })->prio (1);
2659} 2758}
2660 2759
2661=item $player_object->enter_exit ($exit_object) 2760=item $player_object->enter_exit ($exit_object)
2662 2761
… …
2682} 2781}
2683 2782
2684sub prepare_random_map { 2783sub prepare_random_map {
2685 my ($exit) = @_; 2784 my ($exit) = @_;
2686 2785
2687 my $guard = cf::lock_acquire "exit_prepare:$exit";
2688
2689 # all this does is basically replace the /! path by 2786 # all this does is basically replace the /! path by
2690 # a new random map path (?random/...) with a seed 2787 # a new random map path (?random/...) with a seed
2691 # that depends on the exit object 2788 # that depends on the exit object
2692 2789
2693 my $rmp = parse_random_map_params $exit->msg; 2790 my $rmp = parse_random_map_params $exit->msg;
… …
2695 if ($exit->map) { 2792 if ($exit->map) {
2696 $rmp->{region} = $exit->region->name; 2793 $rmp->{region} = $exit->region->name;
2697 $rmp->{origin_map} = $exit->map->path; 2794 $rmp->{origin_map} = $exit->map->path;
2698 $rmp->{origin_x} = $exit->x; 2795 $rmp->{origin_x} = $exit->x;
2699 $rmp->{origin_y} = $exit->y; 2796 $rmp->{origin_y} = $exit->y;
2797
2798 $exit->map->touch;
2700 } 2799 }
2701 2800
2702 $rmp->{random_seed} ||= $exit->random_seed; 2801 $rmp->{random_seed} ||= $exit->random_seed;
2703 2802
2704 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp); 2803 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
… …
2708 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2807 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2709 aio_write $fh, 0, (length $data), $data, 0; 2808 aio_write $fh, 0, (length $data), $data, 0;
2710 undef $fh; 2809 undef $fh;
2711 aio_rename "$meta~", $meta; 2810 aio_rename "$meta~", $meta;
2712 2811
2812 my $slaying = "?random/$md5";
2813
2814 if ($exit->valid) {
2713 $exit->slaying ("?random/$md5"); 2815 $exit->slaying ("?random/$md5");
2714 $exit->msg (undef); 2816 $exit->msg (undef);
2817 }
2715 } 2818 }
2716} 2819}
2717 2820
2718sub cf::object::player::enter_exit { 2821sub cf::object::player::enter_exit {
2719 my ($self, $exit) = @_; 2822 my ($self, $exit) = @_;
2720 2823
2721 return unless $self->type == cf::PLAYER; 2824 return unless $self->type == cf::PLAYER;
2722 2825
2723 if ($exit->slaying eq "/!") {
2724 #TODO: this should de-fi-ni-te-ly not be a sync-job
2725 # the problem is that $exit might not survive long enough
2726 # so it needs to be done right now, right here
2727 cf::sync_job { prepare_random_map $exit };
2728 }
2729
2730 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2731 my $hp = $exit->stats->hp;
2732 my $sp = $exit->stats->sp;
2733
2734 $self->enter_link; 2826 $self->enter_link;
2735 2827
2736 # if exit is damned, update players death & WoR home-position
2737 $self->contr->savebed ($slaying, $hp, $sp)
2738 if $exit->flag (FLAG_DAMNED);
2739
2740 (async { 2828 (async {
2741 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2829 $Coro::current->{desc} = "enter_exit";
2742 2830
2743 $self->deactivate_recursive; # just to be sure
2744 unless (eval { 2831 unless (eval {
2832 $self->deactivate_recursive; # just to be sure
2833
2834 # random map handling
2835 {
2836 my $guard = cf::lock_acquire "exit_prepare:$exit";
2837
2838 prepare_random_map $exit
2839 if $exit->slaying eq "/!";
2840 }
2841
2842 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2843 my $x = $exit->stats->hp;
2844 my $y = $exit->stats->sp;
2845
2745 $self->goto ($slaying, $hp, $sp); 2846 $self->goto ($map, $x, $y);
2746 2847
2848 # if exit is damned, update players death & WoR home-position
2849 $self->contr->savebed ($map, $x, $y)
2850 if $exit->flag (cf::FLAG_DAMNED);
2851
2747 1; 2852 1
2748 }) { 2853 }) {
2749 $self->message ("Something went wrong deep within the crossfire server. " 2854 $self->message ("Something went wrong deep within the deliantra server. "
2750 . "I'll try to bring you back to the map you were before. " 2855 . "I'll try to bring you back to the map you were before. "
2751 . "Please report this to the dungeon master!", 2856 . "Please report this to the dungeon master!",
2752 cf::NDI_UNIQUE | cf::NDI_RED); 2857 cf::NDI_UNIQUE | cf::NDI_RED);
2753 2858
2754 warn "ERROR in enter_exit: $@"; 2859 error "ERROR in enter_exit: $@";
2755 $self->leave_link; 2860 $self->leave_link;
2756 } 2861 }
2757 })->prio (1); 2862 })->prio (1);
2758} 2863}
2759 2864
… …
2771sub cf::client::send_drawinfo { 2876sub cf::client::send_drawinfo {
2772 my ($self, $text, $flags) = @_; 2877 my ($self, $text, $flags) = @_;
2773 2878
2774 utf8::encode $text; 2879 utf8::encode $text;
2775 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2880 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2881}
2882
2883=item $client->send_big_packet ($pkt)
2884
2885Like C<send_packet>, but tries to compress large packets, and fragments
2886them as required.
2887
2888=cut
2889
2890our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2891
2892sub cf::client::send_big_packet {
2893 my ($self, $pkt) = @_;
2894
2895 # try lzf for large packets
2896 $pkt = "lzf " . Compress::LZF::compress $pkt
2897 if 1024 <= length $pkt and $self->{can_lzf};
2898
2899 # split very large packets
2900 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2901 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2902 $pkt = "frag";
2903 }
2904
2905 $self->send_packet ($pkt);
2776} 2906}
2777 2907
2778=item $client->send_msg ($channel, $msg, $color, [extra...]) 2908=item $client->send_msg ($channel, $msg, $color, [extra...])
2779 2909
2780Send a drawinfo or msg packet to the client, formatting the msg for the 2910Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2784 2914
2785=cut 2915=cut
2786 2916
2787# non-persistent channels (usually the info channel) 2917# non-persistent channels (usually the info channel)
2788our %CHANNEL = ( 2918our %CHANNEL = (
2919 "c/motd" => {
2920 id => "infobox",
2921 title => "MOTD",
2922 reply => undef,
2923 tooltip => "The message of the day",
2924 },
2789 "c/identify" => { 2925 "c/identify" => {
2790 id => "infobox", 2926 id => "infobox",
2791 title => "Identify", 2927 title => "Identify",
2792 reply => undef, 2928 reply => undef,
2793 tooltip => "Items recently identified", 2929 tooltip => "Items recently identified",
… …
2795 "c/examine" => { 2931 "c/examine" => {
2796 id => "infobox", 2932 id => "infobox",
2797 title => "Examine", 2933 title => "Examine",
2798 reply => undef, 2934 reply => undef,
2799 tooltip => "Signs and other items you examined", 2935 tooltip => "Signs and other items you examined",
2936 },
2937 "c/shopinfo" => {
2938 id => "infobox",
2939 title => "Shop Info",
2940 reply => undef,
2941 tooltip => "What your bargaining skill tells you about the shop",
2800 }, 2942 },
2801 "c/book" => { 2943 "c/book" => {
2802 id => "infobox", 2944 id => "infobox",
2803 title => "Book", 2945 title => "Book",
2804 reply => undef, 2946 reply => undef,
… …
2820 id => "infobox", 2962 id => "infobox",
2821 title => "Body Parts", 2963 title => "Body Parts",
2822 reply => undef, 2964 reply => undef,
2823 tooltip => "Shows which body parts you posess and are available", 2965 tooltip => "Shows which body parts you posess and are available",
2824 }, 2966 },
2967 "c/statistics" => {
2968 id => "infobox",
2969 title => "Statistics",
2970 reply => undef,
2971 tooltip => "Shows your primary statistics",
2972 },
2973 "c/skills" => {
2974 id => "infobox",
2975 title => "Skills",
2976 reply => undef,
2977 tooltip => "Shows your experience per skill and item power",
2978 },
2979 "c/shopitems" => {
2980 id => "infobox",
2981 title => "Shop Items",
2982 reply => undef,
2983 tooltip => "Shows the items currently for sale in this shop",
2984 },
2985 "c/resistances" => {
2986 id => "infobox",
2987 title => "Resistances",
2988 reply => undef,
2989 tooltip => "Shows your resistances",
2990 },
2991 "c/pets" => {
2992 id => "infobox",
2993 title => "Pets",
2994 reply => undef,
2995 tooltip => "Shows information abotu your pets/a specific pet",
2996 },
2997 "c/perceiveself" => {
2998 id => "infobox",
2999 title => "Perceive Self",
3000 reply => undef,
3001 tooltip => "You gained detailed knowledge about yourself",
3002 },
2825 "c/uptime" => { 3003 "c/uptime" => {
2826 id => "infobox", 3004 id => "infobox",
2827 title => "Uptime", 3005 title => "Uptime",
2828 reply => undef, 3006 reply => undef,
2829 tooltip => "How long the server has been running since last restart", 3007 tooltip => "How long the server has been running since last restart",
… …
2838 id => "party", 3016 id => "party",
2839 title => "Party", 3017 title => "Party",
2840 reply => "gsay ", 3018 reply => "gsay ",
2841 tooltip => "Messages and chat related to your party", 3019 tooltip => "Messages and chat related to your party",
2842 }, 3020 },
3021 "c/death" => {
3022 id => "death",
3023 title => "Death",
3024 reply => undef,
3025 tooltip => "Reason for and more info about your most recent death",
3026 },
3027 "c/say" => $SAY_CHANNEL,
3028 "c/chat" => $CHAT_CHANNEL,
2843); 3029);
2844 3030
2845sub cf::client::send_msg { 3031sub cf::client::send_msg {
2846 my ($self, $channel, $msg, $color, @extra) = @_; 3032 my ($self, $channel, $msg, $color, @extra) = @_;
2847 3033
2848 $msg = $self->pl->expand_cfpod ($msg); 3034 $msg = $self->pl->expand_cfpod ($msg)
3035 unless $color & cf::NDI_VERBATIM;
2849 3036
2850 $color &= cf::NDI_CLIENT_MASK; # just in case... 3037 $color &= cf::NDI_CLIENT_MASK; # just in case...
2851 3038
2852 # check predefined channels, for the benefit of C 3039 # check predefined channels, for the benefit of C
2853 if ($CHANNEL{$channel}) { 3040 if ($CHANNEL{$channel}) {
2854 $channel = $CHANNEL{$channel}; 3041 $channel = $CHANNEL{$channel};
2855 3042
2856 $self->ext_msg (channel_info => $channel) 3043 $self->ext_msg (channel_info => $channel);
2857 if $self->can_msg;
2858
2859 $channel = $channel->{id}; 3044 $channel = $channel->{id};
2860 3045
2861 } elsif (ref $channel) { 3046 } elsif (ref $channel) {
2862 # send meta info to client, if not yet sent 3047 # send meta info to client, if not yet sent
2863 unless (exists $self->{channel}{$channel->{id}}) { 3048 unless (exists $self->{channel}{$channel->{id}}) {
2864 $self->{channel}{$channel->{id}} = $channel; 3049 $self->{channel}{$channel->{id}} = $channel;
2865 $self->ext_msg (channel_info => $channel) 3050 $self->ext_msg (channel_info => $channel);
2866 if $self->can_msg;
2867 } 3051 }
2868 3052
2869 $channel = $channel->{id}; 3053 $channel = $channel->{id};
2870 } 3054 }
2871 3055
2872 return unless @extra || length $msg; 3056 return unless @extra || length $msg;
2873 3057
2874 if ($self->can_msg) {
2875 # default colour, mask it out 3058 # default colour, mask it out
2876 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3059 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2877 if $color & cf::NDI_DEF; 3060 if $color & cf::NDI_DEF;
2878 3061
2879 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3062 my $pkt = "msg "
3063 . $self->{json_coder}->encode (
2880 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3064 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2881 } else { 3065 );
2882 if ($color >= 0) {
2883 # replace some tags by gcfclient-compatible ones
2884 for ($msg) {
2885 1 while
2886 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2887 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2888 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2889 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2890 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2891 }
2892 3066
2893 $color &= cf::NDI_COLOR_MASK; 3067 $self->send_big_packet ($pkt);
2894
2895 utf8::encode $msg;
2896
2897 if (0 && $msg =~ /\[/) {
2898 # COMMAND/INFO
2899 $self->send_packet ("drawextinfo $color 10 8 $msg")
2900 } else {
2901 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2902 $self->send_packet ("drawinfo $color $msg")
2903 }
2904 }
2905 }
2906} 3068}
2907 3069
2908=item $client->ext_msg ($type, @msg) 3070=item $client->ext_msg ($type, @msg)
2909 3071
2910Sends an ext event to the client. 3072Sends an ext event to the client.
… …
2913 3075
2914sub cf::client::ext_msg($$@) { 3076sub cf::client::ext_msg($$@) {
2915 my ($self, $type, @msg) = @_; 3077 my ($self, $type, @msg) = @_;
2916 3078
2917 if ($self->extcmd == 2) { 3079 if ($self->extcmd == 2) {
2918 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3080 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2919 } elsif ($self->extcmd == 1) { # TODO: remove 3081 } elsif ($self->extcmd == 1) { # TODO: remove
2920 push @msg, msgtype => "event_$type"; 3082 push @msg, msgtype => "event_$type";
2921 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3083 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2922 } 3084 }
2923} 3085}
2924 3086
2925=item $client->ext_reply ($msgid, @msg) 3087=item $client->ext_reply ($msgid, @msg)
2926 3088
… …
2930 3092
2931sub cf::client::ext_reply($$@) { 3093sub cf::client::ext_reply($$@) {
2932 my ($self, $id, @msg) = @_; 3094 my ($self, $id, @msg) = @_;
2933 3095
2934 if ($self->extcmd == 2) { 3096 if ($self->extcmd == 2) {
2935 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3097 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2936 } elsif ($self->extcmd == 1) { 3098 } elsif ($self->extcmd == 1) {
2937 #TODO: version 1, remove 3099 #TODO: version 1, remove
2938 unshift @msg, msgtype => "reply", msgid => $id; 3100 unshift @msg, msgtype => "reply", msgid => $id;
2939 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3101 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2940 } 3102 }
2941} 3103}
2942 3104
2943=item $success = $client->query ($flags, "text", \&cb) 3105=item $success = $client->query ($flags, "text", \&cb)
2944 3106
… …
3015 3177
3016 $ns->ext_reply ($reply, @reply) 3178 $ns->ext_reply ($reply, @reply)
3017 if $reply; 3179 if $reply;
3018 3180
3019 } else { 3181 } else {
3020 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3182 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3021 } 3183 }
3022 3184
3023 cf::override; 3185 cf::override;
3024 }, 3186 },
3025); 3187);
… …
3045 3207
3046 $coro 3208 $coro
3047} 3209}
3048 3210
3049cf::client->attach ( 3211cf::client->attach (
3050 on_destroy => sub { 3212 on_client_destroy => sub {
3051 my ($ns) = @_; 3213 my ($ns) = @_;
3052 3214
3053 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3215 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3054 }, 3216 },
3055); 3217);
… …
3071our $safe_hole = new Safe::Hole; 3233our $safe_hole = new Safe::Hole;
3072 3234
3073$SIG{FPE} = 'IGNORE'; 3235$SIG{FPE} = 'IGNORE';
3074 3236
3075$safe->permit_only (Opcode::opset qw( 3237$safe->permit_only (Opcode::opset qw(
3076 :base_core :base_mem :base_orig :base_math 3238 :base_core :base_mem :base_orig :base_math :base_loop
3077 grepstart grepwhile mapstart mapwhile 3239 grepstart grepwhile mapstart mapwhile
3078 sort time 3240 sort time
3079)); 3241));
3080 3242
3081# here we export the classes and methods available to script code 3243# here we export the classes and methods available to script code
… …
3085The following functions and methods are available within a safe environment: 3247The following functions and methods are available within a safe environment:
3086 3248
3087 cf::object 3249 cf::object
3088 contr pay_amount pay_player map x y force_find force_add destroy 3250 contr pay_amount pay_player map x y force_find force_add destroy
3089 insert remove name archname title slaying race decrease split 3251 insert remove name archname title slaying race decrease split
3252 value
3090 3253
3091 cf::object::player 3254 cf::object::player
3092 player 3255 player
3093 3256
3094 cf::player 3257 cf::player
… …
3099 3262
3100=cut 3263=cut
3101 3264
3102for ( 3265for (
3103 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3266 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3104 insert remove inv name archname title slaying race 3267 insert remove inv nrof name archname title slaying race
3105 decrease split destroy)], 3268 decrease split destroy change_exp value msg lore send_msg)],
3106 ["cf::object::player" => qw(player)], 3269 ["cf::object::player" => qw(player)],
3107 ["cf::player" => qw(peaceful)], 3270 ["cf::player" => qw(peaceful send_msg)],
3108 ["cf::map" => qw(trigger)], 3271 ["cf::map" => qw(trigger)],
3109) { 3272) {
3110 no strict 'refs'; 3273 no strict 'refs';
3111 my ($pkg, @funs) = @$_; 3274 my ($pkg, @funs) = @$_;
3112 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3275 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
3130 3293
3131 my $qcode = $code; 3294 my $qcode = $code;
3132 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3295 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3133 $qcode =~ s/\n/\\n/g; 3296 $qcode =~ s/\n/\\n/g;
3134 3297
3298 %vars = (_dummy => 0) unless %vars;
3299
3300 my @res;
3135 local $_; 3301 local $_;
3136 local @safe::cf::_safe_eval_args = values %vars;
3137 3302
3138 my $eval = 3303 my $eval =
3139 "do {\n" 3304 "do {\n"
3140 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3305 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3141 . "#line 0 \"{$qcode}\"\n" 3306 . "#line 0 \"{$qcode}\"\n"
3142 . $code 3307 . $code
3143 . "\n}" 3308 . "\n}"
3144 ; 3309 ;
3145 3310
3311 if ($CFG{safe_eval}) {
3146 sub_generation_inc; 3312 sub_generation_inc;
3313 local @safe::cf::_safe_eval_args = values %vars;
3147 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3314 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3148 sub_generation_inc; 3315 sub_generation_inc;
3316 } else {
3317 local @cf::_safe_eval_args = values %vars;
3318 @res = wantarray ? eval eval : scalar eval $eval;
3319 }
3149 3320
3150 if ($@) { 3321 if ($@) {
3151 warn "$@"; 3322 warn "$@",
3152 warn "while executing safe code '$code'\n"; 3323 "while executing safe code '$code'\n",
3153 warn "with arguments " . (join " ", %vars) . "\n"; 3324 "with arguments " . (join " ", %vars) . "\n";
3154 } 3325 }
3155 3326
3156 wantarray ? @res : $res[0] 3327 wantarray ? @res : $res[0]
3157} 3328}
3158 3329
… …
3172=cut 3343=cut
3173 3344
3174sub register_script_function { 3345sub register_script_function {
3175 my ($fun, $cb) = @_; 3346 my ($fun, $cb) = @_;
3176 3347
3177 no strict 'refs'; 3348 $fun = "safe::$fun" if $CFG{safe_eval};
3178 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3349 *$fun = $safe_hole->wrap ($cb);
3179} 3350}
3180 3351
3181=back 3352=back
3182 3353
3183=cut 3354=cut
… …
3192 # for this (global event?) 3363 # for this (global event?)
3193 %ext::player_env::MUSIC_FACE_CACHE = (); 3364 %ext::player_env::MUSIC_FACE_CACHE = ();
3194 3365
3195 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3366 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3196 3367
3197 warn "loading facedata from $path\n"; 3368 trace "loading facedata from $path\n";
3198 3369
3199 my $facedata; 3370 my $facedata;
3200 0 < aio_load $path, $facedata 3371 0 < aio_load $path, $facedata
3201 or die "$path: $!"; 3372 or die "$path: $!";
3202 3373
… …
3204 3375
3205 $facedata->{version} == 2 3376 $facedata->{version} == 2
3206 or cf::cleanup "$path: version mismatch, cannot proceed."; 3377 or cf::cleanup "$path: version mismatch, cannot proceed.";
3207 3378
3208 # patch in the exptable 3379 # patch in the exptable
3380 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3209 $facedata->{resource}{"res/exp_table"} = { 3381 $facedata->{resource}{"res/exp_table"} = {
3210 type => FT_RSRC, 3382 type => FT_RSRC,
3211 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3383 data => $exp_table,
3384 hash => (Digest::MD5::md5 $exp_table),
3212 }; 3385 };
3213 cf::cede_to_tick; 3386 cf::cede_to_tick;
3214 3387
3215 { 3388 {
3216 my $faces = $facedata->{faceinfo}; 3389 my $faces = $facedata->{faceinfo};
… …
3218 while (my ($face, $info) = each %$faces) { 3391 while (my ($face, $info) = each %$faces) {
3219 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3392 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3220 3393
3221 cf::face::set_visibility $idx, $info->{visibility}; 3394 cf::face::set_visibility $idx, $info->{visibility};
3222 cf::face::set_magicmap $idx, $info->{magicmap}; 3395 cf::face::set_magicmap $idx, $info->{magicmap};
3223 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3396 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3224 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3397 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3225 3398
3226 cf::cede_to_tick; 3399 cf::cede_to_tick;
3227 } 3400 }
3228 3401
3229 while (my ($face, $info) = each %$faces) { 3402 while (my ($face, $info) = each %$faces) {
… …
3234 3407
3235 if (my $smooth = cf::face::find $info->{smooth}) { 3408 if (my $smooth = cf::face::find $info->{smooth}) {
3236 cf::face::set_smooth $idx, $smooth; 3409 cf::face::set_smooth $idx, $smooth;
3237 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3410 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3238 } else { 3411 } else {
3239 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3412 error "smooth face '$info->{smooth}' not found for face '$face'";
3240 } 3413 }
3241 3414
3242 cf::cede_to_tick; 3415 cf::cede_to_tick;
3243 } 3416 }
3244 } 3417 }
… …
3253 3426
3254 cf::anim::invalidate_all; # d'oh 3427 cf::anim::invalidate_all; # d'oh
3255 } 3428 }
3256 3429
3257 { 3430 {
3258 # TODO: for gcfclient pleasure, we should give resources
3259 # that gcfclient doesn't grok a >10000 face index.
3260 my $res = $facedata->{resource}; 3431 my $res = $facedata->{resource};
3261 3432
3262 while (my ($name, $info) = each %$res) { 3433 while (my ($name, $info) = each %$res) {
3263 if (defined $info->{type}) { 3434 if (defined $info->{type}) {
3264 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3435 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3265 my $data;
3266 3436
3267 if ($info->{type} & 1) { 3437 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3268 # prepend meta info
3269
3270 my $meta = $enc->encode ({
3271 name => $name,
3272 %{ $info->{meta} || {} },
3273 });
3274
3275 $data = pack "(w/a*)*", $meta, $info->{data};
3276 } else {
3277 $data = $info->{data};
3278 }
3279
3280 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3281 cf::face::set_type $idx, $info->{type}; 3438 cf::face::set_type $idx, $info->{type};
3282 } else { 3439 } else {
3283 $RESOURCE{$name} = $info; 3440 $RESOURCE{$name} = $info; # unused
3284 } 3441 }
3285 3442
3286 cf::cede_to_tick; 3443 cf::cede_to_tick;
3287 } 3444 }
3288 } 3445 }
3289 3446
3290 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3447 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3291 3448
3292 1 3449 1
3293} 3450}
3294
3295cf::global->attach (on_resource_update => sub {
3296 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3297 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3298
3299 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3300 my $sound = $soundconf->{compat}[$_]
3301 or next;
3302
3303 my $face = cf::face::find "sound/$sound->[1]";
3304 cf::sound::set $sound->[0] => $face;
3305 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3306 }
3307
3308 while (my ($k, $v) = each %{$soundconf->{event}}) {
3309 my $face = cf::face::find "sound/$v";
3310 cf::sound::set $k => $face;
3311 }
3312 }
3313});
3314 3451
3315register_exticmd fx_want => sub { 3452register_exticmd fx_want => sub {
3316 my ($ns, $want) = @_; 3453 my ($ns, $want) = @_;
3317 3454
3318 while (my ($k, $v) = each %$want) { 3455 while (my ($k, $v) = each %$want) {
… …
3357sub reload_treasures { 3494sub reload_treasures {
3358 load_resource_file "$DATADIR/treasures" 3495 load_resource_file "$DATADIR/treasures"
3359 or die "unable to load treasurelists\n"; 3496 or die "unable to load treasurelists\n";
3360} 3497}
3361 3498
3499sub reload_sound {
3500 trace "loading sound config from $DATADIR/sound\n";
3501
3502 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3503 or die "$DATADIR/sound $!";
3504
3505 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3506
3507 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3508 my $sound = $soundconf->{compat}[$_]
3509 or next;
3510
3511 my $face = cf::face::find "sound/$sound->[1]";
3512 cf::sound::set $sound->[0] => $face;
3513 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3514 }
3515
3516 while (my ($k, $v) = each %{$soundconf->{event}}) {
3517 my $face = cf::face::find "sound/$v";
3518 cf::sound::set $k => $face;
3519 }
3520}
3521
3362sub reload_resources { 3522sub reload_resources {
3363 warn "reloading resource files...\n"; 3523 trace "reloading resource files...\n";
3364 3524
3365 reload_facedata; 3525 reload_facedata;
3526 reload_sound;
3366 reload_archetypes; 3527 reload_archetypes;
3367 reload_regions; 3528 reload_regions;
3368 reload_treasures; 3529 reload_treasures;
3369 3530
3370 warn "finished reloading resource files\n"; 3531 trace "finished reloading resource files\n";
3371}
3372
3373sub init {
3374 my $guard = freeze_mainloop;
3375
3376 reload_resources;
3377} 3532}
3378 3533
3379sub reload_config { 3534sub reload_config {
3535 trace "reloading config file...\n";
3536
3380 open my $fh, "<:utf8", "$CONFDIR/config" 3537 open my $fh, "<:utf8", "$CONFDIR/config"
3381 or return; 3538 or return;
3382 3539
3383 local $/; 3540 local $/;
3384 *CFG = YAML::Load <$fh>; 3541 *CFG = YAML::XS::Load scalar <$fh>;
3385 3542
3386 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3543 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3387 3544
3388 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3545 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3389 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3546 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3390 3547
3391 if (exists $CFG{mlockall}) { 3548 if (exists $CFG{mlockall}) {
… …
3393 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3550 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3394 and die "WARNING: m(un)lockall failed: $!\n"; 3551 and die "WARNING: m(un)lockall failed: $!\n";
3395 }; 3552 };
3396 warn $@ if $@; 3553 warn $@ if $@;
3397 } 3554 }
3555
3556 trace "finished reloading resource files\n";
3557}
3558
3559sub pidfile() {
3560 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3561 or die "$PIDFILE: $!";
3562 flock $fh, &Fcntl::LOCK_EX
3563 or die "$PIDFILE: flock: $!";
3564 $fh
3565}
3566
3567# make sure only one server instance is running at any one time
3568sub atomic {
3569 my $fh = pidfile;
3570
3571 my $pid = <$fh>;
3572 kill 9, $pid if $pid > 0;
3573
3574 seek $fh, 0, 0;
3575 print $fh $$;
3576}
3577
3578sub main_loop {
3579 trace "EV::loop starting\n";
3580 if (1) {
3581 EV::loop;
3582 }
3583 trace "EV::loop returned\n";
3584 goto &main_loop unless $REALLY_UNLOOP;
3398} 3585}
3399 3586
3400sub main { 3587sub main {
3588 cf::init_globals; # initialise logging
3589
3590 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3591 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3592 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3593 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3594
3595 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3596
3401 # we must not ever block the main coroutine 3597 # we must not ever block the main coroutine
3402 local $Coro::idle = sub { 3598 local $Coro::idle = sub {
3403 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3599 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3404 (async { 3600 (async {
3405 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3601 $Coro::current->{desc} = "IDLE BUG HANDLER";
3406 EV::loop EV::LOOP_ONESHOT; 3602 EV::loop EV::LOOP_ONESHOT;
3407 })->prio (Coro::PRIO_MAX); 3603 })->prio (Coro::PRIO_MAX);
3408 }; 3604 };
3409 3605
3410 { 3606 evthread_start IO::AIO::poll_fileno;
3411 my $guard = freeze_mainloop; 3607
3608 cf::sync_job {
3609 cf::init_experience;
3610 cf::init_anim;
3611 cf::init_attackmess;
3612 cf::init_dynamic;
3613
3614 cf::load_settings;
3615 cf::load_materials;
3616
3617 reload_resources;
3412 reload_config; 3618 reload_config;
3413 db_init; 3619 db_init;
3620
3621 cf::init_uuid;
3622 cf::init_signals;
3623 cf::init_skills;
3624
3625 cf::init_beforeplay;
3626
3627 atomic;
3628
3414 load_extensions; 3629 load_extensions;
3415 3630
3416 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3631 utime time, time, $RUNTIMEFILE;
3417 evthread_start IO::AIO::poll_fileno; 3632
3633 # no (long-running) fork's whatsoever before this point(!)
3634 use POSIX ();
3635 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3636
3637 (pop @POST_INIT)->(0) while @POST_INIT;
3418 } 3638 };
3419 3639
3420 EV::loop; 3640 cf::object::thawer::errors_are_fatal 0;
3641 info "parse errors in files are no longer fatal from this point on.\n";
3642
3643 main_loop;
3421} 3644}
3422 3645
3423############################################################################# 3646#############################################################################
3424# initialisation and cleanup 3647# initialisation and cleanup
3425 3648
3426# install some emergency cleanup handlers 3649# install some emergency cleanup handlers
3427BEGIN { 3650BEGIN {
3428 our %SIGWATCHER = (); 3651 our %SIGWATCHER = ();
3429 for my $signal (qw(INT HUP TERM)) { 3652 for my $signal (qw(INT HUP TERM)) {
3430 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3653 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3431 cf::cleanup "SIG$signal"; 3654 cf::cleanup "SIG$signal";
3432 }; 3655 };
3433 } 3656 }
3434} 3657}
3435 3658
3436sub write_runtime_sync { 3659sub write_runtime_sync {
3437 my $runtime = "$LOCALDIR/runtime"; 3660 my $t0 = AE::time;
3438 3661
3439 # first touch the runtime file to show we are still running: 3662 # first touch the runtime file to show we are still running:
3440 # the fsync below can take a very very long time. 3663 # the fsync below can take a very very long time.
3441 3664
3442 IO::AIO::aio_utime $runtime, undef, undef; 3665 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3443 3666
3444 my $guard = cf::lock_acquire "write_runtime"; 3667 my $guard = cf::lock_acquire "write_runtime";
3445 3668
3446 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3669 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3447 or return; 3670 or return;
3448 3671
3449 my $value = $cf::RUNTIME + 90 + 10; 3672 my $value = $cf::RUNTIME + 90 + 10;
3450 # 10 is the runtime save interval, for a monotonic clock 3673 # 10 is the runtime save interval, for a monotonic clock
3451 # 60 allows for the watchdog to kill the server. 3674 # 60 allows for the watchdog to kill the server.
… …
3461 aio_utime $fh, undef, undef; 3684 aio_utime $fh, undef, undef;
3462 3685
3463 close $fh 3686 close $fh
3464 or return; 3687 or return;
3465 3688
3466 aio_rename "$runtime~", $runtime 3689 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3467 and return; 3690 and return;
3468 3691
3469 warn "runtime file written.\n"; 3692 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3470 3693
3471 1 3694 1
3472} 3695}
3473 3696
3474our $uuid_lock; 3697our $uuid_lock;
… …
3483 my $uuid = "$LOCALDIR/uuid"; 3706 my $uuid = "$LOCALDIR/uuid";
3484 3707
3485 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 3708 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3486 or return; 3709 or return;
3487 3710
3488 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; 3711 my $value = uuid_seq uuid_cur;
3712
3713 unless ($value) {
3714 info "cowardly refusing to write zero uuid value!\n";
3715 return;
3716 }
3717
3718 my $value = uuid_str $value + $uuid_skip;
3489 $uuid_skip = 0; 3719 $uuid_skip = 0;
3490 3720
3491 (aio_write $fh, 0, (length $value), $value, 0) <= 0 3721 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3492 and return; 3722 and return;
3493 3723
… …
3499 or return; 3729 or return;
3500 3730
3501 aio_rename "$uuid~", $uuid 3731 aio_rename "$uuid~", $uuid
3502 and return; 3732 and return;
3503 3733
3504 warn "uuid file written ($value).\n"; 3734 trace "uuid file written ($value).\n";
3505 3735
3506 1 3736 1
3507 3737
3508} 3738}
3509 3739
… …
3515} 3745}
3516 3746
3517sub emergency_save() { 3747sub emergency_save() {
3518 my $freeze_guard = cf::freeze_mainloop; 3748 my $freeze_guard = cf::freeze_mainloop;
3519 3749
3520 warn "enter emergency perl save\n"; 3750 info "emergency_perl_save: enter\n";
3521 3751
3522 cf::sync_job { 3752 cf::sync_job {
3753 # this is a trade-off: we want to be very quick here, so
3754 # save all maps without fsync, and later call a global sync
3755 # (which in turn might be very very slow)
3756 local $USE_FSYNC = 0;
3757
3523 # use a peculiar iteration method to avoid tripping on perl 3758 # use a peculiar iteration method to avoid tripping on perl
3524 # refcount bugs in for. also avoids problems with players 3759 # refcount bugs in for. also avoids problems with players
3525 # and maps saved/destroyed asynchronously. 3760 # and maps saved/destroyed asynchronously.
3526 warn "begin emergency player save\n"; 3761 info "emergency_perl_save: begin player save\n";
3527 for my $login (keys %cf::PLAYER) { 3762 for my $login (keys %cf::PLAYER) {
3528 my $pl = $cf::PLAYER{$login} or next; 3763 my $pl = $cf::PLAYER{$login} or next;
3529 $pl->valid or next; 3764 $pl->valid or next;
3530 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3765 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3531 $pl->save; 3766 $pl->save;
3532 } 3767 }
3533 warn "end emergency player save\n"; 3768 info "emergency_perl_save: end player save\n";
3534 3769
3535 warn "begin emergency map save\n"; 3770 info "emergency_perl_save: begin map save\n";
3536 for my $path (keys %cf::MAP) { 3771 for my $path (keys %cf::MAP) {
3537 my $map = $cf::MAP{$path} or next; 3772 my $map = $cf::MAP{$path} or next;
3538 $map->valid or next; 3773 $map->valid or next;
3539 $map->save; 3774 $map->save;
3540 } 3775 }
3541 warn "end emergency map save\n"; 3776 info "emergency_perl_save: end map save\n";
3542 3777
3543 warn "begin emergency database checkpoint\n"; 3778 info "emergency_perl_save: begin database checkpoint\n";
3544 BDB::db_env_txn_checkpoint $DB_ENV; 3779 BDB::db_env_txn_checkpoint $DB_ENV;
3545 warn "end emergency database checkpoint\n"; 3780 info "emergency_perl_save: end database checkpoint\n";
3546 3781
3547 warn "begin write uuid\n"; 3782 info "emergency_perl_save: begin write uuid\n";
3548 write_uuid_sync 1; 3783 write_uuid_sync 1;
3549 warn "end write uuid\n"; 3784 info "emergency_perl_save: end write uuid\n";
3550 }; 3785 };
3551 3786
3552 warn "leave emergency perl save\n"; 3787 info "emergency_perl_save: starting sync()\n";
3788 IO::AIO::aio_sync sub {
3789 info "emergency_perl_save: finished sync()\n";
3790 };
3791
3792 info "emergency_perl_save: leave\n";
3553} 3793}
3554 3794
3555sub post_cleanup { 3795sub post_cleanup {
3556 my ($make_core) = @_; 3796 my ($make_core) = @_;
3557 3797
3558 warn Carp::longmess "post_cleanup backtrace" 3798 error Carp::longmess "post_cleanup backtrace"
3559 if $make_core; 3799 if $make_core;
3800
3801 my $fh = pidfile;
3802 unlink $PIDFILE if <$fh> == $$;
3803}
3804
3805# a safer delete_package, copied from Symbol
3806sub clear_package($) {
3807 my $pkg = shift;
3808
3809 # expand to full symbol table name if needed
3810 unless ($pkg =~ /^main::.*::$/) {
3811 $pkg = "main$pkg" if $pkg =~ /^::/;
3812 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3813 $pkg .= '::' unless $pkg =~ /::$/;
3814 }
3815
3816 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3817 my $stem_symtab = *{$stem}{HASH};
3818
3819 defined $stem_symtab and exists $stem_symtab->{$leaf}
3820 or return;
3821
3822 # clear all symbols
3823 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3824 for my $name (keys %$leaf_symtab) {
3825 _gv_clear *{"$pkg$name"};
3826# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3827 }
3560} 3828}
3561 3829
3562sub do_reload_perl() { 3830sub do_reload_perl() {
3563 # can/must only be called in main 3831 # can/must only be called in main
3564 if ($Coro::current != $Coro::main) { 3832 if (in_main) {
3565 warn "can only reload from main coroutine"; 3833 error "can only reload from main coroutine";
3566 return; 3834 return;
3567 } 3835 }
3568 3836
3837 return if $RELOAD++;
3838
3839 my $t1 = AE::time;
3840
3841 while ($RELOAD) {
3569 warn "reloading..."; 3842 info "reloading...";
3570 3843
3571 warn "entering sync_job"; 3844 trace "entering sync_job";
3572 3845
3573 cf::sync_job { 3846 cf::sync_job {
3574 cf::write_runtime_sync; # external watchdog should not bark 3847 cf::write_runtime_sync; # external watchdog should not bark
3575 cf::emergency_save; 3848 cf::emergency_save;
3576 cf::write_runtime_sync; # external watchdog should not bark 3849 cf::write_runtime_sync; # external watchdog should not bark
3577 3850
3578 warn "syncing database to disk"; 3851 trace "syncing database to disk";
3579 BDB::db_env_txn_checkpoint $DB_ENV; 3852 BDB::db_env_txn_checkpoint $DB_ENV;
3580 3853
3581 # if anything goes wrong in here, we should simply crash as we already saved 3854 # if anything goes wrong in here, we should simply crash as we already saved
3582 3855
3583 warn "flushing outstanding aio requests"; 3856 trace "flushing outstanding aio requests";
3584 for (;;) {
3585 BDB::flush;
3586 IO::AIO::flush;
3587 Coro::cede_notself;
3588 last unless IO::AIO::nreqs || BDB::nreqs; 3857 while (IO::AIO::nreqs || BDB::nreqs) {
3589 warn "iterate..."; 3858 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3590 }
3591
3592 ++$RELOAD;
3593
3594 warn "cancelling all extension coros";
3595 $_->cancel for values %EXT_CORO;
3596 %EXT_CORO = ();
3597
3598 warn "removing commands";
3599 %COMMAND = ();
3600
3601 warn "removing ext/exti commands";
3602 %EXTCMD = ();
3603 %EXTICMD = ();
3604
3605 warn "unloading/nuking all extensions";
3606 for my $pkg (@EXTS) {
3607 warn "... unloading $pkg";
3608
3609 if (my $cb = $pkg->can ("unload")) {
3610 eval {
3611 $cb->($pkg);
3612 1
3613 } or warn "$pkg unloaded, but with errors: $@";
3614 } 3859 }
3615 3860
3616 warn "... nuking $pkg"; 3861 trace "cancelling all extension coros";
3617 Symbol::delete_package $pkg; 3862 $_->cancel for values %EXT_CORO;
3618 } 3863 %EXT_CORO = ();
3619 3864
3620 warn "unloading all perl modules loaded from $LIBDIR"; 3865 trace "removing commands";
3621 while (my ($k, $v) = each %INC) { 3866 %COMMAND = ();
3622 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3623 3867
3868 trace "removing ext/exti commands";
3869 %EXTCMD = ();
3870 %EXTICMD = ();
3871
3872 trace "unloading/nuking all extensions";
3873 for my $pkg (@EXTS) {
3624 warn "... unloading $k"; 3874 trace "... unloading $pkg";
3625 delete $INC{$k};
3626 3875
3627 $k =~ s/\.pm$//;
3628 $k =~ s/\//::/g;
3629
3630 if (my $cb = $k->can ("unload_module")) { 3876 if (my $cb = $pkg->can ("unload")) {
3877 eval {
3631 $cb->(); 3878 $cb->($pkg);
3879 1
3880 } or error "$pkg unloaded, but with errors: $@";
3881 }
3882
3883 trace "... clearing $pkg";
3884 clear_package $pkg;
3632 } 3885 }
3633 3886
3634 Symbol::delete_package $k; 3887 trace "unloading all perl modules loaded from $LIBDIR";
3888 while (my ($k, $v) = each %INC) {
3889 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3890
3891 trace "... unloading $k";
3892 delete $INC{$k};
3893
3894 $k =~ s/\.pm$//;
3895 $k =~ s/\//::/g;
3896
3897 if (my $cb = $k->can ("unload_module")) {
3898 $cb->();
3899 }
3900
3901 clear_package $k;
3635 } 3902 }
3636 3903
3637 warn "getting rid of safe::, as good as possible"; 3904 trace "getting rid of safe::, as good as possible";
3638 Symbol::delete_package "safe::$_" 3905 clear_package "safe::$_"
3639 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3906 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3640 3907
3641 warn "unloading cf.pm \"a bit\""; 3908 trace "unloading cf.pm \"a bit\"";
3642 delete $INC{"cf.pm"}; 3909 delete $INC{"cf.pm"};
3643 delete $INC{"cf/pod.pm"}; 3910 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3644 3911
3645 # don't, removes xs symbols, too, 3912 # don't, removes xs symbols, too,
3646 # and global variables created in xs 3913 # and global variables created in xs
3647 #Symbol::delete_package __PACKAGE__; 3914 #clear_package __PACKAGE__;
3648 3915
3649 warn "unload completed, starting to reload now"; 3916 info "unload completed, starting to reload now";
3650 3917
3651 warn "reloading cf.pm"; 3918 trace "reloading cf.pm";
3652 require cf; 3919 require cf;
3653 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3920 cf::_connect_to_perl_1;
3654 3921
3655 warn "loading config and database again"; 3922 trace "loading config and database again";
3656 cf::reload_config; 3923 cf::reload_config;
3657 3924
3658 warn "loading extensions"; 3925 trace "loading extensions";
3659 cf::load_extensions; 3926 cf::load_extensions;
3660 3927
3928 if ($REATTACH_ON_RELOAD) {
3661 warn "reattaching attachments to objects/players"; 3929 trace "reattaching attachments to objects/players";
3662 _global_reattach; # objects, sockets 3930 _global_reattach; # objects, sockets
3663 warn "reattaching attachments to maps"; 3931 trace "reattaching attachments to maps";
3664 reattach $_ for values %MAP; 3932 reattach $_ for values %MAP;
3665 warn "reattaching attachments to players"; 3933 trace "reattaching attachments to players";
3666 reattach $_ for values %PLAYER; 3934 reattach $_ for values %PLAYER;
3935 }
3667 3936
3937 trace "running post_init jobs";
3938 (pop @POST_INIT)->(1) while @POST_INIT;
3939
3668 warn "leaving sync_job"; 3940 trace "leaving sync_job";
3669 3941
3670 1 3942 1
3671 } or do { 3943 } or do {
3672 warn $@; 3944 error $@;
3673 cf::cleanup "error while reloading, exiting."; 3945 cf::cleanup "error while reloading, exiting.";
3946 };
3947
3948 info "reloaded";
3949 --$RELOAD;
3674 }; 3950 }
3675 3951
3676 warn "reloaded"; 3952 $t1 = AE::time - $t1;
3953 info "reload completed in ${t1}s\n";
3677}; 3954};
3678 3955
3679our $RELOAD_WATCHER; # used only during reload 3956our $RELOAD_WATCHER; # used only during reload
3680 3957
3681sub reload_perl() { 3958sub reload_perl() {
3682 # doing reload synchronously and two reloads happen back-to-back, 3959 # doing reload synchronously and two reloads happen back-to-back,
3683 # coro crashes during coro_state_free->destroy here. 3960 # coro crashes during coro_state_free->destroy here.
3684 3961
3962 $RELOAD_WATCHER ||= cf::async {
3963 Coro::AIO::aio_wait cache_extensions;
3964
3685 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 3965 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3686 do_reload_perl; 3966 do_reload_perl;
3687 undef $RELOAD_WATCHER; 3967 undef $RELOAD_WATCHER;
3968 };
3688 }; 3969 };
3689} 3970}
3690 3971
3691register_command "reload" => sub { 3972register_command "reload" => sub {
3692 my ($who, $arg) = @_; 3973 my ($who, $arg) = @_;
… …
3706 3987
3707our @WAIT_FOR_TICK; 3988our @WAIT_FOR_TICK;
3708our @WAIT_FOR_TICK_BEGIN; 3989our @WAIT_FOR_TICK_BEGIN;
3709 3990
3710sub wait_for_tick { 3991sub wait_for_tick {
3711 return if tick_inhibit || $Coro::current == $Coro::main; 3992 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3712 3993
3713 my $signal = new Coro::Signal; 3994 my $signal = new Coro::Signal;
3714 push @WAIT_FOR_TICK, $signal; 3995 push @WAIT_FOR_TICK, $signal;
3715 $signal->wait; 3996 $signal->wait;
3716} 3997}
3717 3998
3718sub wait_for_tick_begin { 3999sub wait_for_tick_begin {
3719 return if tick_inhibit || $Coro::current == $Coro::main; 4000 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3720 4001
3721 my $signal = new Coro::Signal; 4002 my $signal = new Coro::Signal;
3722 push @WAIT_FOR_TICK_BEGIN, $signal; 4003 push @WAIT_FOR_TICK_BEGIN, $signal;
3723 $signal->wait; 4004 $signal->wait;
3724} 4005}
… …
3730 return; 4011 return;
3731 } 4012 }
3732 4013
3733 cf::server_tick; # one server iteration 4014 cf::server_tick; # one server iteration
3734 4015
4016 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4017
3735 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4018 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3736 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4019 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3737 Coro::async_pool { 4020 Coro::async_pool {
3738 $Coro::current->{desc} = "runtime saver"; 4021 $Coro::current->{desc} = "runtime saver";
3739 write_runtime_sync 4022 write_runtime_sync
3740 or warn "ERROR: unable to write runtime file: $!"; 4023 or error "ERROR: unable to write runtime file: $!";
3741 }; 4024 };
3742 } 4025 }
3743 4026
3744 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4027 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3745 $sig->send; 4028 $sig->send;
… …
3753 4036
3754 if (0) { 4037 if (0) {
3755 if ($NEXT_TICK) { 4038 if ($NEXT_TICK) {
3756 my $jitter = $TICK_START - $NEXT_TICK; 4039 my $jitter = $TICK_START - $NEXT_TICK;
3757 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4040 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3758 warn "jitter $JITTER\n";#d# 4041 debug "jitter $JITTER\n";#d#
3759 } 4042 }
3760 } 4043 }
3761} 4044}
3762 4045
3763{ 4046{
3764 # configure BDB 4047 # configure BDB
3765 4048
3766 BDB::min_parallel 8; 4049 BDB::min_parallel 16;
3767 BDB::max_poll_reqs $TICK * 0.1; 4050 BDB::max_poll_reqs $TICK * 0.1;
3768 $Coro::BDB::WATCHER->priority (1); 4051 $AnyEvent::BDB::WATCHER->priority (1);
3769 4052
3770 unless ($DB_ENV) { 4053 unless ($DB_ENV) {
3771 $DB_ENV = BDB::db_env_create; 4054 $DB_ENV = BDB::db_env_create;
3772 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 4055 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3773 | BDB::LOG_AUTOREMOVE, 1); 4056 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4057 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3774 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 4058 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3775 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 4059 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3776 4060
4061 (Coro::async { # async to keep sync_job from complaining
3777 cf::sync_job { 4062 cf::sync_job {
3778 eval { 4063 eval {
3779 BDB::db_env_open 4064 BDB::db_env_open
3780 $DB_ENV, 4065 $DB_ENV,
3781 $BDBDIR, 4066 $BDBDIR,
3782 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 4067 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3783 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4068 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3784 0666; 4069 0666;
3785 4070
3786 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4071 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
4072 };
4073
4074 cf::cleanup "db_env_open(db): $@" if $@;
3787 }; 4075 };
3788 4076 })->join;
3789 cf::cleanup "db_env_open(db): $@" if $@;
3790 };
3791 } 4077 }
3792 4078
3793 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub { 4079 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3794 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { }; 4080 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3795 }; 4081 };
… …
3804{ 4090{
3805 # configure IO::AIO 4091 # configure IO::AIO
3806 4092
3807 IO::AIO::min_parallel 8; 4093 IO::AIO::min_parallel 8;
3808 IO::AIO::max_poll_time $TICK * 0.1; 4094 IO::AIO::max_poll_time $TICK * 0.1;
3809 $Coro::AIO::WATCHER->priority (1); 4095 undef $AnyEvent::AIO::WATCHER;
3810} 4096}
3811 4097
3812my $_log_backtrace; 4098my $_log_backtrace;
3813 4099
3814sub _log_backtrace { 4100sub _log_backtrace {
… …
3817 $msg =~ s/\n//; 4103 $msg =~ s/\n//;
3818 4104
3819 # limit the # of concurrent backtraces 4105 # limit the # of concurrent backtraces
3820 if ($_log_backtrace < 2) { 4106 if ($_log_backtrace < 2) {
3821 ++$_log_backtrace; 4107 ++$_log_backtrace;
4108 my $perl_bt = Carp::longmess $msg;
3822 async { 4109 async {
3823 $Coro::current->{desc} = "abt $msg"; 4110 $Coro::current->{desc} = "abt $msg";
3824 4111
3825 my @bt = fork_call { 4112 my @bt = fork_call {
3826 @addr = map { sprintf "%x", $_ } @addr; 4113 @addr = map { sprintf "%x", $_ } @addr;
… …
3837 } 4124 }
3838 4125
3839 @funcs 4126 @funcs
3840 }; 4127 };
3841 4128
3842 LOG llevInfo, "[ABT] $msg\n"; 4129 LOG llevInfo, "[ABT] $perl_bt\n";
4130 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3843 LOG llevInfo, "[ABT] $_\n" for @bt; 4131 LOG llevInfo, "[ABT] $_\n" for @bt;
3844 --$_log_backtrace; 4132 --$_log_backtrace;
3845 }; 4133 };
3846 } else { 4134 } else {
3847 LOG llevInfo, "[ABT] $msg\n"; 4135 LOG llevInfo, "[ABT] $msg\n";
3848 LOG llevInfo, "[ABT] [suppressed]\n"; 4136 LOG llevInfo, "[ABT] [suppressed]\n";
3849 } 4137 }
3850} 4138}
3851 4139
3852# load additional modules 4140# load additional modules
3853use cf::pod; 4141require "cf/$_.pm" for @EXTRA_MODULES;
4142cf::_connect_to_perl_2;
3854 4143
3855END { cf::emergency_save } 4144END { cf::emergency_save }
3856 4145
38571 41461
3858 4147

Diff Legend

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