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.419 by root, Sun Apr 13 01:34:09 2008 UTC vs.
Revision 1.543 by root, Wed May 5 23:23:29 2010 UTC

1# 1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG. 2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3# 3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5# 5#
6# Deliantra is free software: you can redistribute it and/or modify 6# Deliantra is free software: you can redistribute it and/or modify it under
7# it under the terms of the GNU General Public License as published by 7# the terms of the Affero GNU General Public License as published by the
8# the Free Software Foundation, either version 3 of the License, or 8# Free Software Foundation, either version 3 of the License, or (at your
9# (at your option) any later version. 9# option) any later version.
10# 10#
11# This program is distributed in the hope that it will be useful, 11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of 12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details. 14# GNU General Public License for more details.
15# 15#
16# You should have received a copy of the GNU General Public License 16# You should have received a copy of the Affero GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>. 17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
18# 19#
19# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
20# 21#
21 22
22package cf; 23package cf;
23 24
24use utf8; 25use common::sense;
25use strict;
26 26
27use Symbol; 27use Symbol;
28use List::Util; 28use List::Util;
29use Socket; 29use Socket;
30use EV 3.2; 30use EV;
31use Opcode; 31use Opcode;
32use Safe; 32use Safe;
33use Safe::Hole; 33use Safe::Hole;
34use Storable (); 34use Storable ();
35use Carp ();
35 36
37use Guard ();
36use Coro 4.50 (); 38use Coro ();
37use Coro::State; 39use Coro::State;
38use Coro::Handle; 40use Coro::Handle;
39use Coro::EV; 41use Coro::EV;
42use Coro::AnyEvent;
40use Coro::Timer; 43use Coro::Timer;
41use Coro::Signal; 44use Coro::Signal;
42use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
43use Coro::AIO; 48use Coro::AIO;
44use Coro::BDB; 49use Coro::BDB 1.6;
45use Coro::Storable; 50use Coro::Storable;
46use Coro::Util (); 51use Coro::Util ();
47 52
48use JSON::XS 2.01 (); 53use JSON::XS 2.01 ();
49use BDB (); 54use BDB ();
50use Data::Dumper; 55use Data::Dumper;
51use Digest::MD5;
52use Fcntl; 56use Fcntl;
53use YAML (); 57use YAML::XS ();
54use IO::AIO 2.51 (); 58use IO::AIO ();
55use Time::HiRes; 59use Time::HiRes;
56use Compress::LZF; 60use Compress::LZF;
57use Digest::MD5 (); 61use Digest::MD5 ();
62
63AnyEvent::detect;
58 64
59# configure various modules to our taste 65# configure various modules to our taste
60# 66#
61$Storable::canonical = 1; # reduce rsync transfers 67$Storable::canonical = 1; # reduce rsync transfers
62Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 68Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
69
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71
72# make sure c-lzf reinitialises itself
73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
63Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
64 75
65$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 76# strictly for debugging
77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
66 78
67sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
80
81our @ORIG_INC;
68 82
69our %COMMAND = (); 83our %COMMAND = ();
70our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
71 85
72our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
73our %EXTCMD = (); 87our %EXTCMD = ();
74our %EXTICMD = (); 88our %EXTICMD = ();
75our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
76our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
77 91
78our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
79our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
80 96
81our $CONFDIR = confdir; 97our $CONFDIR = confdir;
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 incloader);
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($;$$) {
482 return if tick_inhibit || $Coro::current == $Coro::main;
483
432 my ($time, $pri, $name) = @_; 484 my ($time, $pri, $name) = @_;
433 485
434 $time = $TICK * .6 if $time > $TICK * .6; 486 $time = clamp $time, 0.01, $TICK * .6;
487
435 my $sig = new Coro::Signal; 488 my $sig = new Coro::Signal;
436 489
437 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 490 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
438 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 491 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
439 $SLOT_QUEUE->ready; 492 $SLOT_QUEUE->ready;
… …
465=cut 518=cut
466 519
467sub sync_job(&) { 520sub sync_job(&) {
468 my ($job) = @_; 521 my ($job) = @_;
469 522
470 if ($Coro::current == $Coro::main) { 523 if (in_main) {
471 my $time = EV::time; 524 my $time = AE::time;
472 525
473 # this is the main coro, too bad, we have to block 526 # this is the main coro, too bad, we have to block
474 # till the operation succeeds, freezing the server :/ 527 # till the operation succeeds, freezing the server :/
475 528
476 LOG llevError, Carp::longmess "sync job";#d# 529 #LOG llevError, Carp::longmess "sync job";#d#
477 530
478 my $freeze_guard = freeze_mainloop; 531 my $freeze_guard = freeze_mainloop;
479 532
480 my $busy = 1; 533 my $busy = 1;
481 my @res; 534 my @res;
482 535
483 (async { 536 (async {
484 $Coro::current->desc ("sync job coro"); 537 $Coro::current->desc ("sync job coro");
485 @res = eval { $job->() }; 538 @res = eval { $job->() };
486 warn $@ if $@; 539 error $@ if $@;
487 undef $busy; 540 undef $busy;
488 })->prio (Coro::PRIO_MAX); 541 })->prio (Coro::PRIO_MAX);
489 542
490 while ($busy) { 543 while ($busy) {
491 if (Coro::nready) { 544 if (Coro::nready) {
… …
493 } else { 546 } else {
494 EV::loop EV::LOOP_ONESHOT; 547 EV::loop EV::LOOP_ONESHOT;
495 } 548 }
496 } 549 }
497 550
498 my $time = EV::time - $time; 551 my $time = AE::time - $time;
499 552
500 $TICK_START += $time; # do not account sync jobs to server load 553 $TICK_START += $time; # do not account sync jobs to server load
501 554
502 wantarray ? @res : $res[0] 555 wantarray ? @res : $res[0]
503 } else { 556 } else {
… …
547 reset_signals; 600 reset_signals;
548 &$cb 601 &$cb
549 }, @args; 602 }, @args;
550 603
551 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 )
552} 616}
553 617
554=item $coin = coin_from_name $name 618=item $coin = coin_from_name $name
555 619
556=cut 620=cut
… …
593within each server. 657within each server.
594 658
595=cut 659=cut
596 660
597sub db_table($) { 661sub db_table($) {
662 cf::error "db_get called from main context"
663 if $Coro::current == $Coro::main;
664
598 my ($name) = @_; 665 my ($name) = @_;
599 my $db = BDB::db_create $DB_ENV; 666 my $db = BDB::db_create $DB_ENV;
600 667
601 eval { 668 eval {
602 $db->set_flags (BDB::CHKSUM); 669 $db->set_flags (BDB::CHKSUM);
… …
612} 679}
613 680
614our $DB; 681our $DB;
615 682
616sub db_init { 683sub db_init {
617 cf::sync_job {
618 $DB ||= db_table "db"; 684 $DB ||= db_table "db";
619 };
620} 685}
621 686
622sub db_get($$) { 687sub db_get($$) {
623 my $key = "$_[0]/$_[1]"; 688 my $key = "$_[0]/$_[1]";
624 689
625 cf::sync_job { 690 cf::error "db_get called from main context"
691 if $Coro::current == $Coro::main;
692
626 BDB::db_get $DB, undef, $key, my $data; 693 BDB::db_get $DB, undef, $key, my $data;
627 694
628 $! ? () 695 $! ? ()
629 : $data 696 : $data
630 }
631} 697}
632 698
633sub db_put($$$) { 699sub db_put($$$) {
634 BDB::dbreq_pri 4; 700 BDB::dbreq_pri 4;
635 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 701 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
691 757
692 my $t1 = Time::HiRes::time; 758 my $t1 = Time::HiRes::time;
693 my $data = $process->(\@data); 759 my $data = $process->(\@data);
694 my $t2 = Time::HiRes::time; 760 my $t2 = Time::HiRes::time;
695 761
696 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 762 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
697 763
698 db_put cache => "$id/data", $data; 764 db_put cache => "$id/data", $data;
699 db_put cache => "$id/md5" , $md5; 765 db_put cache => "$id/md5" , $md5;
700 db_put cache => "$id/meta", $meta; 766 db_put cache => "$id/meta", $meta;
701 767
… …
711 777
712=cut 778=cut
713 779
714sub datalog($@) { 780sub datalog($@) {
715 my ($type, %kv) = @_; 781 my ($type, %kv) = @_;
716 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 782 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
717} 783}
718 784
719=back 785=back
720 786
721=cut 787=cut
722 788
723############################################################################# 789#############################################################################
724 790
725=head2 ATTACHABLE OBJECTS 791=head2 ATTACHABLE OBJECTS
726 792
727Many objects in crossfire are so-called attachable objects. That means you can 793Many objects in deliantra are so-called attachable objects. That means you can
728attach callbacks/event handlers (a collection of which is called an "attachment") 794attach callbacks/event handlers (a collection of which is called an "attachment")
729to it. All such attachable objects support the following methods. 795to it. All such attachable objects support the following methods.
730 796
731In the following description, CLASS can be any of C<global>, C<object> 797In the following description, CLASS can be any of C<global>, C<object>
732C<player>, C<client> or C<map> (i.e. the attachable objects in 798C<player>, C<client> or C<map> (i.e. the attachable objects in
… …
782=item cf::CLASS::attachment $name, ... 848=item cf::CLASS::attachment $name, ...
783 849
784Register an attachment by C<$name> through which attachable objects of the 850Register an attachment by C<$name> through which attachable objects of the
785given CLASS can refer to this attachment. 851given CLASS can refer to this attachment.
786 852
787Some classes such as crossfire maps and objects can specify attachments 853Some classes such as deliantra maps and objects can specify attachments
788that are attached at load/instantiate time, thus the need for a name. 854that are attached at load/instantiate time, thus the need for a name.
789 855
790These calls expect any number of the following handler/hook descriptions: 856These calls expect any number of the following handler/hook descriptions:
791 857
792=over 4 858=over 4
… …
916 982
917 } elsif (exists $cb_id{$type}) { 983 } elsif (exists $cb_id{$type}) {
918 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 984 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
919 985
920 } elsif (ref $type) { 986 } elsif (ref $type) {
921 warn "attaching objects not supported, ignoring.\n"; 987 error "attaching objects not supported, ignoring.\n";
922 988
923 } else { 989 } else {
924 shift @arg; 990 shift @arg;
925 warn "attach argument '$type' not supported, ignoring.\n"; 991 error "attach argument '$type' not supported, ignoring.\n";
926 } 992 }
927 } 993 }
928} 994}
929 995
930sub _object_attach { 996sub _object_attach {
… …
940 _attach $registry, $klass, @attach; 1006 _attach $registry, $klass, @attach;
941 } 1007 }
942 1008
943 $obj->{$name} = \%arg; 1009 $obj->{$name} = \%arg;
944 } else { 1010 } else {
945 warn "object uses attachment '$name' which is not available, postponing.\n"; 1011 info "object uses attachment '$name' which is not available, postponing.\n";
946 } 1012 }
947 1013
948 $obj->{_attachment}{$name} = undef; 1014 $obj->{_attachment}{$name} = undef;
949} 1015}
950 1016
… …
1009 1075
1010 for (@$callbacks) { 1076 for (@$callbacks) {
1011 eval { &{$_->[1]} }; 1077 eval { &{$_->[1]} };
1012 1078
1013 if ($@) { 1079 if ($@) {
1014 warn "$@";
1015 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1080 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1016 override; 1081 override;
1017 } 1082 }
1018 1083
1019 return 1 if $override; 1084 return 1 if $override;
1020 } 1085 }
… …
1083 1148
1084sub reattach { 1149sub reattach {
1085 # basically do the same as instantiate, without calling instantiate 1150 # basically do the same as instantiate, without calling instantiate
1086 my ($obj) = @_; 1151 my ($obj) = @_;
1087 1152
1153 # no longer needed after getting rid of delete_package?
1088 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1154 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
1089 1155
1090 my $registry = $obj->registry; 1156 my $registry = $obj->registry;
1091 1157
1092 @$registry = (); 1158 @$registry = ();
1093 1159
… …
1098 for (@$attach) { 1164 for (@$attach) {
1099 my ($klass, @attach) = @$_; 1165 my ($klass, @attach) = @$_;
1100 _attach $registry, $klass, @attach; 1166 _attach $registry, $klass, @attach;
1101 } 1167 }
1102 } else { 1168 } else {
1103 warn "object uses attachment '$name' that is not available, postponing.\n"; 1169 info "object uses attachment '$name' that is not available, postponing.\n";
1104 } 1170 }
1105 } 1171 }
1106} 1172}
1107 1173
1108cf::attachable->attach ( 1174cf::attachable->attach (
… …
1135 my ($filename, $rdata, $objs) = @_; 1201 my ($filename, $rdata, $objs) = @_;
1136 1202
1137 sync_job { 1203 sync_job {
1138 if (length $$rdata) { 1204 if (length $$rdata) {
1139 utf8::decode (my $decname = $filename); 1205 utf8::decode (my $decname = $filename);
1140 warn sprintf "saving %s (%d,%d)\n", 1206 trace sprintf "saving %s (%d,%d)\n",
1141 $decname, length $$rdata, scalar @$objs; 1207 $decname, length $$rdata, scalar @$objs
1208 if $VERBOSE_IO;
1142 1209
1143 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1210 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1144 chmod SAVE_MODE, $fh; 1211 aio_chmod $fh, SAVE_MODE;
1145 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1212 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1146 aio_fsync $fh if $cf::USE_FSYNC; 1213 if ($cf::USE_FSYNC) {
1214 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1215 aio_fsync $fh;
1216 }
1147 close $fh; 1217 aio_close $fh;
1148 1218
1149 if (@$objs) { 1219 if (@$objs) {
1150 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1220 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1151 chmod SAVE_MODE, $fh; 1221 aio_chmod $fh, SAVE_MODE;
1152 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1222 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1153 aio_write $fh, 0, (length $data), $data, 0; 1223 aio_write $fh, 0, (length $data), $data, 0;
1154 aio_fsync $fh if $cf::USE_FSYNC; 1224 if ($cf::USE_FSYNC) {
1225 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1226 aio_fsync $fh;
1227 }
1155 close $fh; 1228 aio_close $fh;
1156 aio_rename "$filename.pst~", "$filename.pst"; 1229 aio_rename "$filename.pst~", "$filename.pst";
1157 } 1230 }
1158 } else { 1231 } else {
1159 aio_unlink "$filename.pst"; 1232 aio_unlink "$filename.pst";
1160 } 1233 }
1161 1234
1162 aio_rename "$filename~", $filename; 1235 aio_rename "$filename~", $filename;
1236
1237 $filename =~ s%/[^/]+$%%;
1238 aio_pathsync $filename if $cf::USE_FSYNC;
1163 } else { 1239 } else {
1164 warn "FATAL: $filename~: $!\n"; 1240 error "unable to save objects: $filename~: $!\n";
1165 } 1241 }
1166 } else { 1242 } else {
1167 aio_unlink $filename; 1243 aio_unlink $filename;
1168 aio_unlink "$filename.pst"; 1244 aio_unlink "$filename.pst";
1169 } 1245 }
… …
1193 my $st = eval { Coro::Storable::thaw $av }; 1269 my $st = eval { Coro::Storable::thaw $av };
1194 $av = $st->{objs}; 1270 $av = $st->{objs};
1195 } 1271 }
1196 1272
1197 utf8::decode (my $decname = $filename); 1273 utf8::decode (my $decname = $filename);
1198 warn sprintf "loading %s (%d,%d)\n", 1274 trace sprintf "loading %s (%d,%d)\n",
1199 $decname, length $data, scalar @{$av || []}; 1275 $decname, length $data, scalar @{$av || []}
1276 if $VERBOSE_IO;
1200 1277
1201 ($data, $av) 1278 ($data, $av)
1202} 1279}
1203 1280
1204=head2 COMMAND CALLBACKS 1281=head2 COMMAND CALLBACKS
… …
1260 my ($name, $cb) = @_; 1337 my ($name, $cb) = @_;
1261 1338
1262 $EXTICMD{$name} = $cb; 1339 $EXTICMD{$name} = $cb;
1263} 1340}
1264 1341
1342use File::Glob ();
1343
1265cf::player->attach ( 1344cf::player->attach (
1266 on_command => sub { 1345 on_unknown_command => sub {
1267 my ($pl, $name, $params) = @_; 1346 my ($pl, $name, $params) = @_;
1268 1347
1269 my $cb = $COMMAND{$name} 1348 my $cb = $COMMAND{$name}
1270 or return; 1349 or return;
1271 1350
… …
1294 1373
1295 $pl->ext_reply ($reply, @reply) 1374 $pl->ext_reply ($reply, @reply)
1296 if $reply; 1375 if $reply;
1297 1376
1298 } else { 1377 } else {
1299 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1378 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1300 } 1379 }
1301 1380
1302 cf::override; 1381 cf::override;
1303 }, 1382 },
1304); 1383);
1305 1384
1385# "readahead" all extensions
1386sub cache_extensions {
1387 my $grp = IO::AIO::aio_group;
1388
1389 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1390 for (grep /\.ext$/, @{$_[0]}) {
1391 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1392 }
1393 };
1394
1395 $grp
1396}
1397
1306sub load_extensions { 1398sub load_extensions {
1399 info "loading extensions...";
1400
1307 cf::sync_job { 1401 cf::sync_job {
1308 my %todo; 1402 my %todo;
1309 1403
1310 for my $path (<$LIBDIR/*.ext>) { 1404 for my $path (<$LIBDIR/*.ext>) {
1311 next unless -r $path; 1405 next unless -r $path;
… …
1329 1423
1330 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1424 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1331 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1425 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1332 1426
1333 $ext{source} = 1427 $ext{source} =
1334 "package $pkg; use strict; use utf8;\n" 1428 "package $pkg; use common::sense;\n"
1335 . "#line 1 \"$path\"\n{\n" 1429 . "#line 1 \"$path\"\n{\n"
1336 . $source 1430 . $source
1337 . "\n};\n1"; 1431 . "\n};\n1";
1338 1432
1339 $todo{$base} = \%ext; 1433 $todo{$base} = \%ext;
1340 } 1434 }
1341 1435
1436 my $pass = 0;
1342 my %done; 1437 my %done;
1343 while (%todo) { 1438 while (%todo) {
1344 my $progress; 1439 my $progress;
1345 1440
1441 ++$pass;
1442
1443 ext:
1346 while (my ($k, $v) = each %todo) { 1444 while (my ($k, $v) = each %todo) {
1347 for (split /,\s*/, $v->{meta}{depends}) { 1445 for (split /,\s*/, $v->{meta}{depends}) {
1348 goto skip 1446 next ext
1349 unless exists $done{$_}; 1447 unless exists $done{$_};
1350 } 1448 }
1351 1449
1352 warn "... loading '$k' into '$v->{pkg}'\n"; 1450 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1353 1451
1354 unless (eval $v->{source}) { 1452 my $active = eval $v->{source};
1453
1454 if (length $@) {
1355 my $msg = $@ ? "$v->{path}: $@\n" 1455 error "$v->{path}: $@\n";
1356 : "$v->{base}: extension inactive.\n";
1357 1456
1358 if (exists $v->{meta}{mandatory}) {
1359 warn $msg;
1360 cf::cleanup "mandatory extension failed to load, exiting."; 1457 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1361 } 1458 if exists $v->{meta}{mandatory};
1362 1459
1363 warn $msg; 1460 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1461 delete $todo{$k};
1462 } else {
1463 $done{$k} = delete $todo{$k};
1464 push @EXTS, $v->{pkg};
1465 $progress = 1;
1466
1467 info "$v->{base}: extension inactive.\n"
1468 unless $active;
1364 } 1469 }
1365
1366 $done{$k} = delete $todo{$k};
1367 push @EXTS, $v->{pkg};
1368 $progress = 1;
1369 } 1470 }
1370 1471
1371 skip: 1472 unless ($progress) {
1372 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1473 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1373 unless $progress; 1474
1475 while (my ($k, $v) = each %todo) {
1476 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1477 if exists $v->{meta}{mandatory};
1478 }
1479 }
1374 } 1480 }
1375 }; 1481 };
1376} 1482}
1377 1483
1378############################################################################# 1484#############################################################################
1379 1485
1380=back 1486=back
1381 1487
1382=head2 CORE EXTENSIONS 1488=head2 CORE EXTENSIONS
1383 1489
1384Functions and methods that extend core crossfire objects. 1490Functions and methods that extend core deliantra objects.
1385 1491
1386=cut 1492=cut
1387 1493
1388package cf::player; 1494package cf::player;
1389 1495
… …
1432 1538
1433sub exists($) { 1539sub exists($) {
1434 my ($login) = @_; 1540 my ($login) = @_;
1435 1541
1436 $cf::PLAYER{$login} 1542 $cf::PLAYER{$login}
1437 or cf::sync_job { !aio_stat path $login } 1543 or !aio_stat path $login
1438} 1544}
1439 1545
1440sub find($) { 1546sub find($) {
1441 return $cf::PLAYER{$_[0]} || do { 1547 return $cf::PLAYER{$_[0]} || do {
1442 my $login = $_[0]; 1548 my $login = $_[0];
… …
1454 my $f = new_from_file cf::object::thawer path $login 1560 my $f = new_from_file cf::object::thawer path $login
1455 or return; 1561 or return;
1456 1562
1457 my $pl = cf::player::load_pl $f 1563 my $pl = cf::player::load_pl $f
1458 or return; 1564 or return;
1565
1459 local $cf::PLAYER_LOADING{$login} = $pl; 1566 local $cf::PLAYER_LOADING{$login} = $pl;
1460 $f->resolve_delayed_derefs; 1567 $f->resolve_delayed_derefs;
1461 $cf::PLAYER{$login} = $pl 1568 $cf::PLAYER{$login} = $pl
1462 } 1569 }
1463 } 1570 }
1464} 1571}
1465 1572
1573cf::player->attach (
1574 on_load => sub {
1575 my ($pl, $path) = @_;
1576
1577 # restore slots saved in save, below
1578 my $slots = delete $pl->{_slots};
1579
1580 $pl->ob->current_weapon ($slots->[0]);
1581 $pl->combat_ob ($slots->[1]);
1582 $pl->ranged_ob ($slots->[2]);
1583 },
1584);
1585
1466sub save($) { 1586sub save($) {
1467 my ($pl) = @_; 1587 my ($pl) = @_;
1468 1588
1469 return if $pl->{deny_save}; 1589 return if $pl->{deny_save};
1470 1590
… …
1473 1593
1474 return if $pl->{deny_save}; 1594 return if $pl->{deny_save};
1475 1595
1476 aio_mkdir playerdir $pl, 0770; 1596 aio_mkdir playerdir $pl, 0770;
1477 $pl->{last_save} = $cf::RUNTIME; 1597 $pl->{last_save} = $cf::RUNTIME;
1598
1599 cf::get_slot 0.01;
1600
1601 # save slots, to be restored later
1602 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1478 1603
1479 $pl->save_pl ($path); 1604 $pl->save_pl ($path);
1480 cf::cede_to_tick; 1605 cf::cede_to_tick;
1481} 1606}
1482 1607
… …
1514 my ($pl) = @_; 1639 my ($pl) = @_;
1515 1640
1516 my $name = $pl->ob->name; 1641 my $name = $pl->ob->name;
1517 1642
1518 $pl->{deny_save} = 1; 1643 $pl->{deny_save} = 1;
1519 $pl->password ("*"); # this should lock out the player until we nuked the dir 1644 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1520 1645
1521 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1646 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1522 $pl->deactivate; 1647 $pl->deactivate;
1648 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1523 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1649 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1524 $pl->ns->destroy if $pl->ns; 1650 $pl->ns->destroy if $pl->ns;
1525 1651
1526 my $path = playerdir $pl; 1652 my $path = playerdir $pl;
1527 my $temp = "$path~$cf::RUNTIME~deleting~"; 1653 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1566 1692
1567 for my $login (@$dirs) { 1693 for my $login (@$dirs) {
1568 my $path = path $login; 1694 my $path = path $login;
1569 1695
1570 # a .pst is a dead give-away for a valid player 1696 # a .pst is a dead give-away for a valid player
1571 unless (-e "$path.pst") { 1697 # if no pst file found, open and chekc for blocked users
1698 if (aio_stat "$path.pst") {
1572 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1699 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1573 aio_read $fh, 0, 512, my $buf, 0 or next; 1700 aio_read $fh, 0, 512, my $buf, 0 or next;
1574 $buf !~ /^password -------------$/m or next; # official not-valid tag 1701 $buf !~ /^password -------------$/m or next; # official not-valid tag
1575 } 1702 }
1576 1703
… …
1580 1707
1581 \@logins 1708 \@logins
1582} 1709}
1583 1710
1584=item $player->maps 1711=item $player->maps
1712
1713=item cf::player::maps $login
1585 1714
1586Returns an arrayref of map paths that are private for this 1715Returns an arrayref of map paths that are private for this
1587player. May block. 1716player. May block.
1588 1717
1589=cut 1718=cut
… …
1607 } 1736 }
1608 1737
1609 \@paths 1738 \@paths
1610} 1739}
1611 1740
1612=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1741=item $protocol_xml = $player->expand_cfpod ($cfpod)
1613 1742
1614Expand crossfire pod fragments into protocol xml. 1743Expand deliantra pod fragments into protocol xml.
1615
1616=cut
1617
1618use re 'eval';
1619
1620my $group;
1621my $interior; $interior = qr{
1622 # match a pod interior sequence sans C<< >>
1623 (?:
1624 \ (.*?)\ (?{ $group = $^N })
1625 | < (??{$interior}) >
1626 )
1627}x;
1628
1629sub expand_cfpod {
1630 my ($self, $pod) = @_;
1631
1632 my $xml;
1633
1634 while () {
1635 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1636 $group = $1;
1637
1638 $group =~ s/&/&amp;/g;
1639 $group =~ s/</&lt;/g;
1640
1641 $xml .= $group;
1642 } elsif ($pod =~ m%\G
1643 ([BCGHITU])
1644 <
1645 (?:
1646 ([^<>]*) (?{ $group = $^N })
1647 | < $interior >
1648 )
1649 >
1650 %gcsx
1651 ) {
1652 my ($code, $data) = ($1, $group);
1653
1654 if ($code eq "B") {
1655 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1656 } elsif ($code eq "I") {
1657 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1658 } elsif ($code eq "U") {
1659 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1660 } elsif ($code eq "C") {
1661 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1662 } elsif ($code eq "T") {
1663 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1664 } elsif ($code eq "G") {
1665 my ($male, $female) = split /\|/, $data;
1666 $data = $self->gender ? $female : $male;
1667 $xml .= expand_cfpod ($self, $data);
1668 } elsif ($code eq "H") {
1669 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1670 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1671 "")
1672 [$self->{hintmode}];
1673 } else {
1674 $xml .= "error processing '$code($data)' directive";
1675 }
1676 } else {
1677 if ($pod =~ /\G(.+)/) {
1678 warn "parse error while expanding $pod (at $1)";
1679 }
1680 last;
1681 }
1682 }
1683
1684 for ($xml) {
1685 # create single paragraphs (very hackish)
1686 s/(?<=\S)\n(?=\w)/ /g;
1687
1688 # compress some whitespace
1689 s/\s+\n/\n/g; # ws line-ends
1690 s/\n\n+/\n/g; # double lines
1691 s/^\n+//; # beginning lines
1692 s/\n+$//; # ending lines
1693 }
1694
1695 $xml
1696}
1697
1698no re 'eval';
1699
1700sub hintmode {
1701 $_[0]{hintmode} = $_[1] if @_ > 1;
1702 $_[0]{hintmode}
1703}
1704 1744
1705=item $player->ext_reply ($msgid, @msg) 1745=item $player->ext_reply ($msgid, @msg)
1706 1746
1707Sends an ext reply to the player. 1747Sends an ext reply to the player.
1708 1748
… …
1740 1780
1741=cut 1781=cut
1742 1782
1743sub find_by_path($) { 1783sub find_by_path($) {
1744 my ($path) = @_; 1784 my ($path) = @_;
1785
1786 $path =~ s/^~[^\/]*//; # skip ~login
1745 1787
1746 my ($match, $specificity); 1788 my ($match, $specificity);
1747 1789
1748 for my $region (list) { 1790 for my $region (list) {
1749 if ($region->{match} && $path =~ $region->{match}) { 1791 if ($region->{match} && $path =~ $region->{match}) {
… …
1781 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1823 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1782 1824
1783 # mit "rum" bekleckern, nicht 1825 # mit "rum" bekleckern, nicht
1784 $self->_create_random_map ( 1826 $self->_create_random_map (
1785 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1827 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1786 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1828 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1787 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1829 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1788 $rmp->{exit_on_final_map}, 1830 $rmp->{exit_on_final_map},
1789 $rmp->{xsize}, $rmp->{ysize}, 1831 $rmp->{xsize}, $rmp->{ysize},
1790 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1832 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1791 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1833 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1806 1848
1807sub register { 1849sub register {
1808 my (undef, $regex, $prio) = @_; 1850 my (undef, $regex, $prio) = @_;
1809 my $pkg = caller; 1851 my $pkg = caller;
1810 1852
1811 no strict;
1812 push @{"$pkg\::ISA"}, __PACKAGE__; 1853 push @{"$pkg\::ISA"}, __PACKAGE__;
1813 1854
1814 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1855 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1815} 1856}
1816 1857
1817# also paths starting with '/' 1858# also paths starting with '/'
1818$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1859$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1819 1860
1820sub thawer_merge { 1861sub thawer_merge {
1821 my ($self, $merge) = @_; 1862 my ($self, $merge) = @_;
1822 1863
1823 # we have to keep some variables in memory intact 1864 # we have to keep some variables in memory intact
… …
1828} 1869}
1829 1870
1830sub normalise { 1871sub normalise {
1831 my ($path, $base) = @_; 1872 my ($path, $base) = @_;
1832 1873
1833 $path = "$path"; # make sure its a string 1874 $path = "$path"; # make sure it's a string
1834 1875
1835 $path =~ s/\.map$//; 1876 $path =~ s/\.map$//;
1836 1877
1837 # map plan: 1878 # map plan:
1838 # 1879 #
… …
1877 $self->init; # pass $1 etc. 1918 $self->init; # pass $1 etc.
1878 return $self; 1919 return $self;
1879 } 1920 }
1880 } 1921 }
1881 1922
1882 Carp::cluck "unable to resolve path '$path' (base '$base')."; 1923 Carp::cluck "unable to resolve path '$path' (base '$base')";
1883 () 1924 ()
1884} 1925}
1885 1926
1886sub init { 1927sub init {
1887 my ($self) = @_; 1928 my ($self) = @_;
… …
1919sub uniq_path { 1960sub uniq_path {
1920 my ($self) = @_; 1961 my ($self) = @_;
1921 1962
1922 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go; 1963 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1923 "$UNIQUEDIR/$path" 1964 "$UNIQUEDIR/$path"
1924}
1925
1926# and all this just because we cannot iterate over
1927# all maps in C++...
1928sub change_all_map_light {
1929 my ($change) = @_;
1930
1931 $_->change_map_light ($change)
1932 for grep $_->outdoor, values %cf::MAP;
1933} 1965}
1934 1966
1935sub decay_objects { 1967sub decay_objects {
1936 my ($self) = @_; 1968 my ($self) = @_;
1937 1969
… …
2019 2051
2020sub find; 2052sub find;
2021sub find { 2053sub find {
2022 my ($path, $origin) = @_; 2054 my ($path, $origin) = @_;
2023 2055
2056 cf::cede_to_tick;
2057
2024 $path = normalise $path, $origin && $origin->path; 2058 $path = normalise $path, $origin && $origin->path;
2025 2059
2026 cf::lock_wait "map_data:$path";#d#remove 2060 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2027 cf::lock_wait "map_find:$path"; 2061 my $guard2 = cf::lock_acquire "map_find:$path";
2028 2062
2029 $cf::MAP{$path} || do { 2063 $cf::MAP{$path} || do {
2030 my $guard1 = cf::lock_acquire "map_find:$path";
2031 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
2032
2033 my $map = new_from_path cf::map $path 2064 my $map = new_from_path cf::map $path
2034 or return; 2065 or return;
2035 2066
2036 $map->{last_save} = $cf::RUNTIME; 2067 $map->{last_save} = $cf::RUNTIME;
2037 2068
… …
2039 or return; 2070 or return;
2040 2071
2041 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2072 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2042 # doing this can freeze the server in a sync job, obviously 2073 # doing this can freeze the server in a sync job, obviously
2043 #$cf::WAIT_FOR_TICK->wait; 2074 #$cf::WAIT_FOR_TICK->wait;
2075 undef $guard2;
2044 undef $guard1; 2076 undef $guard1;
2045 undef $guard2;
2046 $map->reset; 2077 $map->reset;
2047 return find $path; 2078 return find $path;
2048 } 2079 }
2049 2080
2050 $cf::MAP{$path} = $map 2081 $cf::MAP{$path} = $map
2051 } 2082 }
2052} 2083}
2053 2084
2054sub pre_load { } 2085sub pre_load { }
2055sub post_load { } 2086#sub post_load { } # XS
2056 2087
2057sub load { 2088sub load {
2058 my ($self) = @_; 2089 my ($self) = @_;
2059 2090
2060 local $self->{deny_reset} = 1; # loading can take a long time 2091 local $self->{deny_reset} = 1; # loading can take a long time
… …
2077 my $f = new_from_file cf::object::thawer $self->{load_path}; 2108 my $f = new_from_file cf::object::thawer $self->{load_path};
2078 $f->skip_block; 2109 $f->skip_block;
2079 $self->_load_objects ($f) 2110 $self->_load_objects ($f)
2080 or return; 2111 or return;
2081 2112
2082 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2113 $self->post_load_original
2083 if delete $self->{load_original}; 2114 if delete $self->{load_original};
2084 2115
2085 if (my $uniq = $self->uniq_path) { 2116 if (my $uniq = $self->uniq_path) {
2086 utf8::encode $uniq; 2117 utf8::encode $uniq;
2087 unless (aio_stat $uniq) { 2118 unless (aio_stat $uniq) {
… …
2105 unless ($self->{deny_activate}) { 2136 unless ($self->{deny_activate}) {
2106 $self->decay_objects; 2137 $self->decay_objects;
2107 $self->fix_auto_apply; 2138 $self->fix_auto_apply;
2108 $self->update_buttons; 2139 $self->update_buttons;
2109 cf::cede_to_tick; 2140 cf::cede_to_tick;
2110 $self->set_darkness_map;
2111 cf::cede_to_tick;
2112 $self->activate; 2141 $self->activate;
2113 } 2142 }
2114 2143
2115 $self->{last_save} = $cf::RUNTIME; 2144 $self->{last_save} = $cf::RUNTIME;
2116 $self->last_access ($cf::RUNTIME); 2145 $self->last_access ($cf::RUNTIME);
2117 2146
2118 $self->in_memory (cf::MAP_IN_MEMORY); 2147 $self->in_memory (cf::MAP_ACTIVE);
2119 } 2148 }
2120 2149
2121 $self->post_load; 2150 $self->post_load;
2122} 2151}
2123 2152
2153# customize the map for a given player, i.e.
2154# return the _real_ map. used by e.g. per-player
2155# maps to change the path to ~playername/mappath
2124sub customise_for { 2156sub customise_for {
2125 my ($self, $ob) = @_; 2157 my ($self, $ob) = @_;
2126 2158
2127 return find "~" . $ob->name . "/" . $self->{path} 2159 return find "~" . $ob->name . "/" . $self->{path}
2128 if $self->per_player; 2160 if $self->per_player;
… …
2144 or next; 2176 or next;
2145 $neigh = find $neigh, $map 2177 $neigh = find $neigh, $map
2146 or next; 2178 or next;
2147 $neigh->load; 2179 $neigh->load;
2148 2180
2181 # now find the diagonal neighbours
2149 push @neigh, 2182 push @neigh,
2150 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2183 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2151 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2184 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2152 } 2185 }
2153 2186
… …
2160} 2193}
2161 2194
2162sub find_sync { 2195sub find_sync {
2163 my ($path, $origin) = @_; 2196 my ($path, $origin) = @_;
2164 2197
2165 cf::sync_job { find $path, $origin } 2198 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2199 if $Coro::current == $Coro::main;
2200
2201 find $path, $origin
2166} 2202}
2167 2203
2168sub do_load_sync { 2204sub do_load_sync {
2169 my ($map) = @_; 2205 my ($map) = @_;
2170 2206
2171 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2207 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2172 if $Coro::current == $Coro::main; 2208 if $Coro::current == $Coro::main;
2173 2209
2174 cf::sync_job { $map->load }; 2210 $map->load;
2175} 2211}
2176 2212
2177our %MAP_PREFETCH; 2213our %MAP_PREFETCH;
2178our $MAP_PREFETCHER = undef; 2214our $MAP_PREFETCHER = undef;
2179 2215
… …
2181 my ($path, $origin, $load) = @_; 2217 my ($path, $origin, $load) = @_;
2182 2218
2183 $path = normalise $path, $origin && $origin->{path}; 2219 $path = normalise $path, $origin && $origin->{path};
2184 2220
2185 if (my $map = $cf::MAP{$path}) { 2221 if (my $map = $cf::MAP{$path}) {
2186 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2222 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2187 } 2223 }
2188 2224
2189 $MAP_PREFETCH{$path} |= $load; 2225 $MAP_PREFETCH{$path} |= $load;
2190 2226
2191 $MAP_PREFETCHER ||= cf::async { 2227 $MAP_PREFETCHER ||= cf::async {
… …
2205 $MAP_PREFETCHER->prio (6); 2241 $MAP_PREFETCHER->prio (6);
2206 2242
2207 () 2243 ()
2208} 2244}
2209 2245
2246# common code, used by both ->save and ->swapout
2210sub save { 2247sub _save {
2211 my ($self) = @_; 2248 my ($self) = @_;
2212
2213 my $lock = cf::lock_acquire "map_data:$self->{path}";
2214 2249
2215 $self->{last_save} = $cf::RUNTIME; 2250 $self->{last_save} = $cf::RUNTIME;
2216 2251
2217 return unless $self->dirty; 2252 return unless $self->dirty;
2218 2253
… …
2227 2262
2228 cf::async { 2263 cf::async {
2229 $Coro::current->{desc} = "map player save"; 2264 $Coro::current->{desc} = "map player save";
2230 $_->contr->save for $self->players; 2265 $_->contr->save for $self->players;
2231 }; 2266 };
2267
2268 cf::get_slot 0.02;
2232 2269
2233 if ($uniq) { 2270 if ($uniq) {
2234 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2271 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2235 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2272 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2236 } else { 2273 } else {
2237 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2274 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2238 } 2275 }
2239} 2276}
2240 2277
2278sub save {
2279 my ($self) = @_;
2280
2281 my $lock = cf::lock_acquire "map_data:$self->{path}";
2282
2283 $self->_save;
2284}
2285
2241sub swap_out { 2286sub swap_out {
2242 my ($self) = @_; 2287 my ($self) = @_;
2243 2288
2244 # save first because save cedes
2245 $self->save;
2246
2247 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2289 my $lock = cf::lock_acquire "map_data:$self->{path}";
2248 2290
2291 return if $self->in_memory != cf::MAP_ACTIVE;
2292 return if $self->{deny_save};
2249 return if $self->players; 2293 return if $self->players;
2250 return if $self->in_memory != cf::MAP_IN_MEMORY;
2251 return if $self->{deny_save};
2252 2294
2295 # first deactivate the map and "unlink" it from the core
2296 $self->deactivate;
2297 $_->clear_links_to ($self) for values %cf::MAP;
2253 $self->in_memory (cf::MAP_SWAPPED); 2298 $self->in_memory (cf::MAP_SWAPPED);
2299
2300 # then atomically save
2301 $self->_save;
2302
2303 # then free the map
2304 $self->clear;
2305}
2306
2307sub reset_at {
2308 my ($self) = @_;
2309
2310 # TODO: safety, remove and allow resettable per-player maps
2311 return 1e99 if $self->{deny_reset};
2312
2313 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2314 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2315
2316 $time + $to
2317}
2318
2319sub should_reset {
2320 my ($self) = @_;
2321
2322 $self->reset_at <= $cf::RUNTIME
2323}
2324
2325sub reset {
2326 my ($self) = @_;
2327
2328 my $lock = cf::lock_acquire "map_data:$self->{path}";
2329
2330 return if $self->players;
2331
2332 cf::trace "resetting map ", $self->path, "\n";
2333
2334 $self->in_memory (cf::MAP_SWAPPED);
2335
2336 # need to save uniques path
2337 unless ($self->{deny_save}) {
2338 my $uniq = $self->uniq_path; utf8::encode $uniq;
2339
2340 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2341 if $uniq;
2342 }
2343
2344 delete $cf::MAP{$self->path};
2254 2345
2255 $self->deactivate; 2346 $self->deactivate;
2256 $_->clear_links_to ($self) for values %cf::MAP; 2347 $_->clear_links_to ($self) for values %cf::MAP;
2257 $self->clear; 2348 $self->clear;
2258}
2259
2260sub reset_at {
2261 my ($self) = @_;
2262
2263 # TODO: safety, remove and allow resettable per-player maps
2264 return 1e99 if $self->{deny_reset};
2265
2266 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2267 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2268
2269 $time + $to
2270}
2271
2272sub should_reset {
2273 my ($self) = @_;
2274
2275 $self->reset_at <= $cf::RUNTIME
2276}
2277
2278sub reset {
2279 my ($self) = @_;
2280
2281 my $lock = cf::lock_acquire "map_data:$self->{path}";
2282
2283 return if $self->players;
2284
2285 warn "resetting map ", $self->path;
2286
2287 $self->in_memory (cf::MAP_SWAPPED);
2288
2289 # need to save uniques path
2290 unless ($self->{deny_save}) {
2291 my $uniq = $self->uniq_path; utf8::encode $uniq;
2292
2293 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2294 if $uniq;
2295 }
2296
2297 delete $cf::MAP{$self->path};
2298
2299 $self->deactivate;
2300 $_->clear_links_to ($self) for values %cf::MAP;
2301 $self->clear;
2302 2349
2303 $self->unlink_save; 2350 $self->unlink_save;
2304 $self->destroy; 2351 $self->destroy;
2305} 2352}
2306 2353
… …
2314 2361
2315 delete $cf::MAP{$self->path}; 2362 delete $cf::MAP{$self->path};
2316 2363
2317 $self->unlink_save; 2364 $self->unlink_save;
2318 2365
2319 bless $self, "cf::map"; 2366 bless $self, "cf::map::wrap";
2320 delete $self->{deny_reset}; 2367 delete $self->{deny_reset};
2321 $self->{deny_save} = 1; 2368 $self->{deny_save} = 1;
2322 $self->reset_timeout (1); 2369 $self->reset_timeout (1);
2323 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2370 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2324 2371
… …
2381 : normalise $_ 2428 : normalise $_
2382 } @{ aio_readdir $UNIQUEDIR or [] } 2429 } @{ aio_readdir $UNIQUEDIR or [] }
2383 ] 2430 ]
2384} 2431}
2385 2432
2433=item cf::map::static_maps
2434
2435Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2436file in the shared directory excluding F</styles> and F</editor>). May
2437block.
2438
2439=cut
2440
2441sub static_maps() {
2442 my @dirs = "";
2443 my @maps;
2444
2445 while (@dirs) {
2446 my $dir = shift @dirs;
2447
2448 next if $dir eq "/styles" || $dir eq "/editor";
2449
2450 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2451 or return;
2452
2453 for (@$files) {
2454 s/\.map$// or next;
2455 utf8::decode $_;
2456 push @maps, "$dir/$_";
2457 }
2458
2459 push @dirs, map "$dir/$_", @$dirs;
2460 }
2461
2462 \@maps
2463}
2464
2386=back 2465=back
2387 2466
2388=head3 cf::object 2467=head3 cf::object
2389 2468
2390=cut 2469=cut
… …
2451can be C<undef>. Does the right thing when the player is currently in a 2530can be C<undef>. Does the right thing when the player is currently in a
2452dialogue with the given NPC character. 2531dialogue with the given NPC character.
2453 2532
2454=cut 2533=cut
2455 2534
2535our $SAY_CHANNEL = {
2536 id => "say",
2537 title => "Map",
2538 reply => "say ",
2539 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2540};
2541
2542our $CHAT_CHANNEL = {
2543 id => "chat",
2544 title => "Chat",
2545 reply => "chat ",
2546 tooltip => "Player chat and shouts, global to the server.",
2547};
2548
2456# rough implementation of a future "reply" method that works 2549# rough implementation of a future "reply" method that works
2457# with dialog boxes. 2550# with dialog boxes.
2458#TODO: the first argument must go, split into a $npc->reply_to ( method 2551#TODO: the first argument must go, split into a $npc->reply_to ( method
2459sub cf::object::player::reply($$$;$) { 2552sub cf::object::player::reply($$$;$) {
2460 my ($self, $npc, $msg, $flags) = @_; 2553 my ($self, $npc, $msg, $flags) = @_;
… …
2471 my $dialog = $pl->{npc_dialog}; 2564 my $dialog = $pl->{npc_dialog};
2472 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2565 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2473 2566
2474 } else { 2567 } else {
2475 $msg = $npc->name . " says: $msg" if $npc; 2568 $msg = $npc->name . " says: $msg" if $npc;
2476 $self->message ($msg, $flags); 2569 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2477 } 2570 }
2478 } 2571 }
2479} 2572}
2480 2573
2481=item $object->send_msg ($channel, $msg, $color, [extra...]) 2574=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2506 2599
2507=item $player_object->enter_link 2600=item $player_object->enter_link
2508 2601
2509Freezes the player and moves him/her to a special map (C<{link}>). 2602Freezes the player and moves him/her to a special map (C<{link}>).
2510 2603
2511The player should be reasonably safe there for short amounts of time. You 2604The player should be reasonably safe there for short amounts of time (e.g.
2512I<MUST> call C<leave_link> as soon as possible, though. 2605for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2606though, as the player cannot control the character while it is on the link
2607map.
2513 2608
2514Will never block. 2609Will never block.
2515 2610
2516=item $player_object->leave_link ($map, $x, $y) 2611=item $player_object->leave_link ($map, $x, $y)
2517 2612
… …
2537sub cf::object::player::enter_link { 2632sub cf::object::player::enter_link {
2538 my ($self) = @_; 2633 my ($self) = @_;
2539 2634
2540 $self->deactivate_recursive; 2635 $self->deactivate_recursive;
2541 2636
2637 ++$self->{_link_recursion};
2638
2542 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2639 return if UNIVERSAL::isa $self->map, "ext::map_link";
2543 2640
2544 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2641 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2545 if $self->map && $self->map->{path} ne "{link}"; 2642 if $self->map && $self->map->{path} ne "{link}";
2546 2643
2547 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2644 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2548} 2645}
2549 2646
2550sub cf::object::player::leave_link { 2647sub cf::object::player::leave_link {
2551 my ($self, $map, $x, $y) = @_; 2648 my ($self, $map, $x, $y) = @_;
2552 2649
… …
2569 ($x, $y) = (-1, -1) 2666 ($x, $y) = (-1, -1)
2570 unless (defined $x) && (defined $y); 2667 unless (defined $x) && (defined $y);
2571 2668
2572 # use -1 or undef as default coordinates, not 0, 0 2669 # use -1 or undef as default coordinates, not 0, 0
2573 ($x, $y) = ($map->enter_x, $map->enter_y) 2670 ($x, $y) = ($map->enter_x, $map->enter_y)
2574 if $x <=0 && $y <= 0; 2671 if $x <= 0 && $y <= 0;
2575 2672
2576 $map->load; 2673 $map->load;
2577 $map->load_neighbours; 2674 $map->load_neighbours;
2578 2675
2579 return unless $self->contr->active; 2676 return unless $self->contr->active;
2580 $self->activate_recursive;
2581 2677
2582 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2678 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2583 $self->enter_map ($map, $x, $y); 2679 if ($self->enter_map ($map, $x, $y)) {
2584} 2680 # entering was successful
2681 delete $self->{_link_recursion};
2682 # only activate afterwards, to support waiting in hooks
2683 $self->activate_recursive;
2684 }
2585 2685
2686}
2687
2586=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2688=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2587 2689
2588Moves the player to the given map-path and coordinates by first freezing 2690Moves the player to the given map-path and coordinates by first freezing
2589her, loading and preparing them map, calling the provided $check callback 2691her, loading and preparing them map, calling the provided $check callback
2590that has to return the map if sucecssful, and then unfreezes the player on 2692that has to return the map if sucecssful, and then unfreezes the player on
2591the new (success) or old (failed) map position. In either case, $done will 2693the new (success) or old (failed) map position. In either case, $done will
2592be called at the end of this process. 2694be called at the end of this process.
2593 2695
2696Note that $check will be called with a potentially non-loaded map, so if
2697it needs a loaded map it has to call C<< ->load >>.
2698
2594=cut 2699=cut
2595 2700
2596our $GOTOGEN; 2701our $GOTOGEN;
2597 2702
2598sub cf::object::player::goto { 2703sub cf::object::player::goto {
2599 my ($self, $path, $x, $y, $check, $done) = @_; 2704 my ($self, $path, $x, $y, $check, $done) = @_;
2705
2706 if ($self->{_link_recursion} >= $MAX_LINKS) {
2707 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2708 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2709 ($path, $x, $y) = @$EMERGENCY_POSITION;
2710 }
2600 2711
2601 # do generation counting so two concurrent goto's will be executed in-order 2712 # do generation counting so two concurrent goto's will be executed in-order
2602 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2713 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2603 2714
2604 $self->enter_link; 2715 $self->enter_link;
… …
2628 my $map = eval { 2739 my $map = eval {
2629 my $map = defined $path ? cf::map::find $path : undef; 2740 my $map = defined $path ? cf::map::find $path : undef;
2630 2741
2631 if ($map) { 2742 if ($map) {
2632 $map = $map->customise_for ($self); 2743 $map = $map->customise_for ($self);
2633 $map = $check->($map) if $check && $map; 2744 $map = $check->($map, $x, $y, $self) if $check && $map;
2634 } else { 2745 } else {
2635 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2746 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2636 } 2747 }
2637 2748
2638 $map 2749 $map
… …
2646 if ($gen == $self->{_goto_generation}) { 2757 if ($gen == $self->{_goto_generation}) {
2647 delete $self->{_goto_generation}; 2758 delete $self->{_goto_generation};
2648 $self->leave_link ($map, $x, $y); 2759 $self->leave_link ($map, $x, $y);
2649 } 2760 }
2650 2761
2651 $done->() if $done; 2762 $done->($self) if $done;
2652 })->prio (1); 2763 })->prio (1);
2653} 2764}
2654 2765
2655=item $player_object->enter_exit ($exit_object) 2766=item $player_object->enter_exit ($exit_object)
2656 2767
… …
2676} 2787}
2677 2788
2678sub prepare_random_map { 2789sub prepare_random_map {
2679 my ($exit) = @_; 2790 my ($exit) = @_;
2680 2791
2681 my $guard = cf::lock_acquire "exit_prepare:$exit";
2682
2683 # all this does is basically replace the /! path by 2792 # all this does is basically replace the /! path by
2684 # a new random map path (?random/...) with a seed 2793 # a new random map path (?random/...) with a seed
2685 # that depends on the exit object 2794 # that depends on the exit object
2686 2795
2687 my $rmp = parse_random_map_params $exit->msg; 2796 my $rmp = parse_random_map_params $exit->msg;
… …
2689 if ($exit->map) { 2798 if ($exit->map) {
2690 $rmp->{region} = $exit->region->name; 2799 $rmp->{region} = $exit->region->name;
2691 $rmp->{origin_map} = $exit->map->path; 2800 $rmp->{origin_map} = $exit->map->path;
2692 $rmp->{origin_x} = $exit->x; 2801 $rmp->{origin_x} = $exit->x;
2693 $rmp->{origin_y} = $exit->y; 2802 $rmp->{origin_y} = $exit->y;
2803
2804 $exit->map->touch;
2694 } 2805 }
2695 2806
2696 $rmp->{random_seed} ||= $exit->random_seed; 2807 $rmp->{random_seed} ||= $exit->random_seed;
2697 2808
2698 my $data = cf::encode_json $rmp; 2809 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2699 my $md5 = Digest::MD5::md5_hex $data; 2810 my $md5 = Digest::MD5::md5_hex $data;
2700 my $meta = "$RANDOMDIR/$md5.meta"; 2811 my $meta = "$RANDOMDIR/$md5.meta";
2701 2812
2702 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2813 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2703 aio_write $fh, 0, (length $data), $data, 0; 2814 aio_write $fh, 0, (length $data), $data, 0;
2704 undef $fh; 2815 undef $fh;
2705 aio_rename "$meta~", $meta; 2816 aio_rename "$meta~", $meta;
2706 2817
2818 my $slaying = "?random/$md5";
2819
2820 if ($exit->valid) {
2707 $exit->slaying ("?random/$md5"); 2821 $exit->slaying ("?random/$md5");
2708 $exit->msg (undef); 2822 $exit->msg (undef);
2823 }
2709 } 2824 }
2710} 2825}
2711 2826
2712sub cf::object::player::enter_exit { 2827sub cf::object::player::enter_exit {
2713 my ($self, $exit) = @_; 2828 my ($self, $exit) = @_;
2714 2829
2715 return unless $self->type == cf::PLAYER; 2830 return unless $self->type == cf::PLAYER;
2716 2831
2717 if ($exit->slaying eq "/!") {
2718 #TODO: this should de-fi-ni-te-ly not be a sync-job
2719 # the problem is that $exit might not survive long enough
2720 # so it needs to be done right now, right here
2721 cf::sync_job { prepare_random_map $exit };
2722 }
2723
2724 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2725 my $hp = $exit->stats->hp;
2726 my $sp = $exit->stats->sp;
2727
2728 $self->enter_link; 2832 $self->enter_link;
2729 2833
2730 # if exit is damned, update players death & WoR home-position
2731 $self->contr->savebed ($slaying, $hp, $sp)
2732 if $exit->flag (FLAG_DAMNED);
2733
2734 (async { 2834 (async {
2735 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2835 $Coro::current->{desc} = "enter_exit";
2736 2836
2737 $self->deactivate_recursive; # just to be sure
2738 unless (eval { 2837 unless (eval {
2838 $self->deactivate_recursive; # just to be sure
2839
2840 # random map handling
2841 {
2842 my $guard = cf::lock_acquire "exit_prepare:$exit";
2843
2844 prepare_random_map $exit
2845 if $exit->slaying eq "/!";
2846 }
2847
2848 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2849 my $x = $exit->stats->hp;
2850 my $y = $exit->stats->sp;
2851
2739 $self->goto ($slaying, $hp, $sp); 2852 $self->goto ($map, $x, $y);
2740 2853
2854 # if exit is damned, update players death & WoR home-position
2855 $self->contr->savebed ($map, $x, $y)
2856 if $exit->flag (cf::FLAG_DAMNED);
2857
2741 1; 2858 1
2742 }) { 2859 }) {
2743 $self->message ("Something went wrong deep within the crossfire server. " 2860 $self->message ("Something went wrong deep within the deliantra server. "
2744 . "I'll try to bring you back to the map you were before. " 2861 . "I'll try to bring you back to the map you were before. "
2745 . "Please report this to the dungeon master!", 2862 . "Please report this to the dungeon master!",
2746 cf::NDI_UNIQUE | cf::NDI_RED); 2863 cf::NDI_UNIQUE | cf::NDI_RED);
2747 2864
2748 warn "ERROR in enter_exit: $@"; 2865 error "ERROR in enter_exit: $@";
2749 $self->leave_link; 2866 $self->leave_link;
2750 } 2867 }
2751 })->prio (1); 2868 })->prio (1);
2752} 2869}
2753 2870
… …
2765sub cf::client::send_drawinfo { 2882sub cf::client::send_drawinfo {
2766 my ($self, $text, $flags) = @_; 2883 my ($self, $text, $flags) = @_;
2767 2884
2768 utf8::encode $text; 2885 utf8::encode $text;
2769 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2886 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2887}
2888
2889=item $client->send_big_packet ($pkt)
2890
2891Like C<send_packet>, but tries to compress large packets, and fragments
2892them as required.
2893
2894=cut
2895
2896our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2897
2898sub cf::client::send_big_packet {
2899 my ($self, $pkt) = @_;
2900
2901 # try lzf for large packets
2902 $pkt = "lzf " . Compress::LZF::compress $pkt
2903 if 1024 <= length $pkt and $self->{can_lzf};
2904
2905 # split very large packets
2906 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2907 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2908 $pkt = "frag";
2909 }
2910
2911 $self->send_packet ($pkt);
2770} 2912}
2771 2913
2772=item $client->send_msg ($channel, $msg, $color, [extra...]) 2914=item $client->send_msg ($channel, $msg, $color, [extra...])
2773 2915
2774Send a drawinfo or msg packet to the client, formatting the msg for the 2916Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2778 2920
2779=cut 2921=cut
2780 2922
2781# non-persistent channels (usually the info channel) 2923# non-persistent channels (usually the info channel)
2782our %CHANNEL = ( 2924our %CHANNEL = (
2925 "c/motd" => {
2926 id => "infobox",
2927 title => "MOTD",
2928 reply => undef,
2929 tooltip => "The message of the day",
2930 },
2783 "c/identify" => { 2931 "c/identify" => {
2784 id => "infobox", 2932 id => "infobox",
2785 title => "Identify", 2933 title => "Identify",
2786 reply => undef, 2934 reply => undef,
2787 tooltip => "Items recently identified", 2935 tooltip => "Items recently identified",
… …
2789 "c/examine" => { 2937 "c/examine" => {
2790 id => "infobox", 2938 id => "infobox",
2791 title => "Examine", 2939 title => "Examine",
2792 reply => undef, 2940 reply => undef,
2793 tooltip => "Signs and other items you examined", 2941 tooltip => "Signs and other items you examined",
2942 },
2943 "c/shopinfo" => {
2944 id => "infobox",
2945 title => "Shop Info",
2946 reply => undef,
2947 tooltip => "What your bargaining skill tells you about the shop",
2794 }, 2948 },
2795 "c/book" => { 2949 "c/book" => {
2796 id => "infobox", 2950 id => "infobox",
2797 title => "Book", 2951 title => "Book",
2798 reply => undef, 2952 reply => undef,
… …
2814 id => "infobox", 2968 id => "infobox",
2815 title => "Body Parts", 2969 title => "Body Parts",
2816 reply => undef, 2970 reply => undef,
2817 tooltip => "Shows which body parts you posess and are available", 2971 tooltip => "Shows which body parts you posess and are available",
2818 }, 2972 },
2973 "c/statistics" => {
2974 id => "infobox",
2975 title => "Statistics",
2976 reply => undef,
2977 tooltip => "Shows your primary statistics",
2978 },
2979 "c/skills" => {
2980 id => "infobox",
2981 title => "Skills",
2982 reply => undef,
2983 tooltip => "Shows your experience per skill and item power",
2984 },
2985 "c/shopitems" => {
2986 id => "infobox",
2987 title => "Shop Items",
2988 reply => undef,
2989 tooltip => "Shows the items currently for sale in this shop",
2990 },
2991 "c/resistances" => {
2992 id => "infobox",
2993 title => "Resistances",
2994 reply => undef,
2995 tooltip => "Shows your resistances",
2996 },
2997 "c/pets" => {
2998 id => "infobox",
2999 title => "Pets",
3000 reply => undef,
3001 tooltip => "Shows information abotu your pets/a specific pet",
3002 },
3003 "c/perceiveself" => {
3004 id => "infobox",
3005 title => "Perceive Self",
3006 reply => undef,
3007 tooltip => "You gained detailed knowledge about yourself",
3008 },
2819 "c/uptime" => { 3009 "c/uptime" => {
2820 id => "infobox", 3010 id => "infobox",
2821 title => "Uptime", 3011 title => "Uptime",
2822 reply => undef, 3012 reply => undef,
2823 tooltip => "How long the server has been running since last restart", 3013 tooltip => "How long the server has been running since last restart",
… …
2826 id => "infobox", 3016 id => "infobox",
2827 title => "Map Info", 3017 title => "Map Info",
2828 reply => undef, 3018 reply => undef,
2829 tooltip => "Information related to the maps", 3019 tooltip => "Information related to the maps",
2830 }, 3020 },
3021 "c/party" => {
3022 id => "party",
3023 title => "Party",
3024 reply => "gsay ",
3025 tooltip => "Messages and chat related to your party",
3026 },
3027 "c/death" => {
3028 id => "death",
3029 title => "Death",
3030 reply => undef,
3031 tooltip => "Reason for and more info about your most recent death",
3032 },
3033 "c/say" => $SAY_CHANNEL,
3034 "c/chat" => $CHAT_CHANNEL,
2831); 3035);
2832 3036
2833sub cf::client::send_msg { 3037sub cf::client::send_msg {
2834 my ($self, $channel, $msg, $color, @extra) = @_; 3038 my ($self, $channel, $msg, $color, @extra) = @_;
2835 3039
2836 $msg = $self->pl->expand_cfpod ($msg); 3040 $msg = $self->pl->expand_cfpod ($msg)
3041 unless $color & cf::NDI_VERBATIM;
2837 3042
2838 $color &= cf::NDI_CLIENT_MASK; # just in case... 3043 $color &= cf::NDI_CLIENT_MASK; # just in case...
2839 3044
2840 # check predefined channels, for the benefit of C 3045 # check predefined channels, for the benefit of C
2841 if ($CHANNEL{$channel}) { 3046 if ($CHANNEL{$channel}) {
2842 $channel = $CHANNEL{$channel}; 3047 $channel = $CHANNEL{$channel};
2843 3048
2844 $self->ext_msg (channel_info => $channel) 3049 $self->ext_msg (channel_info => $channel);
2845 if $self->can_msg;
2846
2847 $channel = $channel->{id}; 3050 $channel = $channel->{id};
2848 3051
2849 } elsif (ref $channel) { 3052 } elsif (ref $channel) {
2850 # send meta info to client, if not yet sent 3053 # send meta info to client, if not yet sent
2851 unless (exists $self->{channel}{$channel->{id}}) { 3054 unless (exists $self->{channel}{$channel->{id}}) {
2852 $self->{channel}{$channel->{id}} = $channel; 3055 $self->{channel}{$channel->{id}} = $channel;
2853 $self->ext_msg (channel_info => $channel) 3056 $self->ext_msg (channel_info => $channel);
2854 if $self->can_msg;
2855 } 3057 }
2856 3058
2857 $channel = $channel->{id}; 3059 $channel = $channel->{id};
2858 } 3060 }
2859 3061
2860 return unless @extra || length $msg; 3062 return unless @extra || length $msg;
2861 3063
2862 if ($self->can_msg) {
2863 # default colour, mask it out 3064 # default colour, mask it out
2864 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3065 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2865 if $color & cf::NDI_DEF; 3066 if $color & cf::NDI_DEF;
2866 3067
2867 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3068 my $pkt = "msg "
3069 . $self->{json_coder}->encode (
2868 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3070 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2869 } else { 3071 );
2870 if ($color >= 0) {
2871 # replace some tags by gcfclient-compatible ones
2872 for ($msg) {
2873 1 while
2874 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2875 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2876 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2877 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2878 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2879 }
2880 3072
2881 $color &= cf::NDI_COLOR_MASK; 3073 $self->send_big_packet ($pkt);
2882
2883 utf8::encode $msg;
2884
2885 if (0 && $msg =~ /\[/) {
2886 # COMMAND/INFO
2887 $self->send_packet ("drawextinfo $color 10 8 $msg")
2888 } else {
2889 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2890 $self->send_packet ("drawinfo $color $msg")
2891 }
2892 }
2893 }
2894} 3074}
2895 3075
2896=item $client->ext_msg ($type, @msg) 3076=item $client->ext_msg ($type, @msg)
2897 3077
2898Sends an ext event to the client. 3078Sends an ext event to the client.
… …
2901 3081
2902sub cf::client::ext_msg($$@) { 3082sub cf::client::ext_msg($$@) {
2903 my ($self, $type, @msg) = @_; 3083 my ($self, $type, @msg) = @_;
2904 3084
2905 if ($self->extcmd == 2) { 3085 if ($self->extcmd == 2) {
2906 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3086 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2907 } elsif ($self->extcmd == 1) { # TODO: remove 3087 } elsif ($self->extcmd == 1) { # TODO: remove
2908 push @msg, msgtype => "event_$type"; 3088 push @msg, msgtype => "event_$type";
2909 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3089 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2910 } 3090 }
2911} 3091}
2912 3092
2913=item $client->ext_reply ($msgid, @msg) 3093=item $client->ext_reply ($msgid, @msg)
2914 3094
… …
2918 3098
2919sub cf::client::ext_reply($$@) { 3099sub cf::client::ext_reply($$@) {
2920 my ($self, $id, @msg) = @_; 3100 my ($self, $id, @msg) = @_;
2921 3101
2922 if ($self->extcmd == 2) { 3102 if ($self->extcmd == 2) {
2923 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3103 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2924 } elsif ($self->extcmd == 1) { 3104 } elsif ($self->extcmd == 1) {
2925 #TODO: version 1, remove 3105 #TODO: version 1, remove
2926 unshift @msg, msgtype => "reply", msgid => $id; 3106 unshift @msg, msgtype => "reply", msgid => $id;
2927 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3107 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2928 } 3108 }
2929} 3109}
2930 3110
2931=item $success = $client->query ($flags, "text", \&cb) 3111=item $success = $client->query ($flags, "text", \&cb)
2932 3112
… …
3003 3183
3004 $ns->ext_reply ($reply, @reply) 3184 $ns->ext_reply ($reply, @reply)
3005 if $reply; 3185 if $reply;
3006 3186
3007 } else { 3187 } else {
3008 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3188 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3009 } 3189 }
3010 3190
3011 cf::override; 3191 cf::override;
3012 }, 3192 },
3013); 3193);
… …
3033 3213
3034 $coro 3214 $coro
3035} 3215}
3036 3216
3037cf::client->attach ( 3217cf::client->attach (
3038 on_destroy => sub { 3218 on_client_destroy => sub {
3039 my ($ns) = @_; 3219 my ($ns) = @_;
3040 3220
3041 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3221 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3042 }, 3222 },
3043); 3223);
… …
3059our $safe_hole = new Safe::Hole; 3239our $safe_hole = new Safe::Hole;
3060 3240
3061$SIG{FPE} = 'IGNORE'; 3241$SIG{FPE} = 'IGNORE';
3062 3242
3063$safe->permit_only (Opcode::opset qw( 3243$safe->permit_only (Opcode::opset qw(
3064 :base_core :base_mem :base_orig :base_math 3244 :base_core :base_mem :base_orig :base_math :base_loop
3065 grepstart grepwhile mapstart mapwhile 3245 grepstart grepwhile mapstart mapwhile
3066 sort time 3246 sort time
3067)); 3247));
3068 3248
3069# here we export the classes and methods available to script code 3249# here we export the classes and methods available to script code
… …
3072 3252
3073The following functions and methods are available within a safe environment: 3253The following functions and methods are available within a safe environment:
3074 3254
3075 cf::object 3255 cf::object
3076 contr pay_amount pay_player map x y force_find force_add destroy 3256 contr pay_amount pay_player map x y force_find force_add destroy
3077 insert remove name archname title slaying race decrease_ob_nr 3257 insert remove name archname title slaying race decrease split
3258 value
3078 3259
3079 cf::object::player 3260 cf::object::player
3080 player 3261 player
3081 3262
3082 cf::player 3263 cf::player
… …
3087 3268
3088=cut 3269=cut
3089 3270
3090for ( 3271for (
3091 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3272 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3092 insert remove inv name archname title slaying race 3273 insert remove inv nrof name archname title slaying race
3093 decrease_ob_nr destroy)], 3274 decrease split destroy change_exp value msg lore send_msg)],
3094 ["cf::object::player" => qw(player)], 3275 ["cf::object::player" => qw(player)],
3095 ["cf::player" => qw(peaceful)], 3276 ["cf::player" => qw(peaceful send_msg)],
3096 ["cf::map" => qw(trigger)], 3277 ["cf::map" => qw(trigger)],
3097) { 3278) {
3098 no strict 'refs';
3099 my ($pkg, @funs) = @$_; 3279 my ($pkg, @funs) = @$_;
3100 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3280 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3101 for @funs; 3281 for @funs;
3102} 3282}
3103 3283
… …
3118 3298
3119 my $qcode = $code; 3299 my $qcode = $code;
3120 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3300 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3121 $qcode =~ s/\n/\\n/g; 3301 $qcode =~ s/\n/\\n/g;
3122 3302
3303 %vars = (_dummy => 0) unless %vars;
3304
3305 my @res;
3123 local $_; 3306 local $_;
3124 local @safe::cf::_safe_eval_args = values %vars;
3125 3307
3126 my $eval = 3308 my $eval =
3127 "do {\n" 3309 "do {\n"
3128 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3310 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3129 . "#line 0 \"{$qcode}\"\n" 3311 . "#line 0 \"{$qcode}\"\n"
3130 . $code 3312 . $code
3131 . "\n}" 3313 . "\n}"
3132 ; 3314 ;
3133 3315
3316 if ($CFG{safe_eval}) {
3134 sub_generation_inc; 3317 sub_generation_inc;
3318 local @safe::cf::_safe_eval_args = values %vars;
3135 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3319 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3136 sub_generation_inc; 3320 sub_generation_inc;
3321 } else {
3322 local @cf::_safe_eval_args = values %vars;
3323 @res = wantarray ? eval eval : scalar eval $eval;
3324 }
3137 3325
3138 if ($@) { 3326 if ($@) {
3139 warn "$@"; 3327 warn "$@",
3140 warn "while executing safe code '$code'\n"; 3328 "while executing safe code '$code'\n",
3141 warn "with arguments " . (join " ", %vars) . "\n"; 3329 "with arguments " . (join " ", %vars) . "\n";
3142 } 3330 }
3143 3331
3144 wantarray ? @res : $res[0] 3332 wantarray ? @res : $res[0]
3145} 3333}
3146 3334
… …
3160=cut 3348=cut
3161 3349
3162sub register_script_function { 3350sub register_script_function {
3163 my ($fun, $cb) = @_; 3351 my ($fun, $cb) = @_;
3164 3352
3165 no strict 'refs'; 3353 $fun = "safe::$fun" if $CFG{safe_eval};
3166 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3354 *$fun = $safe_hole->wrap ($cb);
3167} 3355}
3168 3356
3169=back 3357=back
3170 3358
3171=cut 3359=cut
… …
3180 # for this (global event?) 3368 # for this (global event?)
3181 %ext::player_env::MUSIC_FACE_CACHE = (); 3369 %ext::player_env::MUSIC_FACE_CACHE = ();
3182 3370
3183 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3371 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3184 3372
3185 warn "loading facedata from $path\n"; 3373 trace "loading facedata from $path\n";
3186 3374
3187 my $facedata; 3375 my $facedata;
3188 0 < aio_load $path, $facedata 3376 0 < aio_load $path, $facedata
3189 or die "$path: $!"; 3377 or die "$path: $!";
3190 3378
… …
3192 3380
3193 $facedata->{version} == 2 3381 $facedata->{version} == 2
3194 or cf::cleanup "$path: version mismatch, cannot proceed."; 3382 or cf::cleanup "$path: version mismatch, cannot proceed.";
3195 3383
3196 # patch in the exptable 3384 # patch in the exptable
3385 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3197 $facedata->{resource}{"res/exp_table"} = { 3386 $facedata->{resource}{"res/exp_table"} = {
3198 type => FT_RSRC, 3387 type => FT_RSRC,
3199 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3388 data => $exp_table,
3389 hash => (Digest::MD5::md5 $exp_table),
3200 }; 3390 };
3201 cf::cede_to_tick; 3391 cf::cede_to_tick;
3202 3392
3203 { 3393 {
3204 my $faces = $facedata->{faceinfo}; 3394 my $faces = $facedata->{faceinfo};
… …
3206 while (my ($face, $info) = each %$faces) { 3396 while (my ($face, $info) = each %$faces) {
3207 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3397 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3208 3398
3209 cf::face::set_visibility $idx, $info->{visibility}; 3399 cf::face::set_visibility $idx, $info->{visibility};
3210 cf::face::set_magicmap $idx, $info->{magicmap}; 3400 cf::face::set_magicmap $idx, $info->{magicmap};
3211 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3401 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3212 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3402 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3213 3403
3214 cf::cede_to_tick; 3404 cf::cede_to_tick;
3215 } 3405 }
3216 3406
3217 while (my ($face, $info) = each %$faces) { 3407 while (my ($face, $info) = each %$faces) {
… …
3222 3412
3223 if (my $smooth = cf::face::find $info->{smooth}) { 3413 if (my $smooth = cf::face::find $info->{smooth}) {
3224 cf::face::set_smooth $idx, $smooth; 3414 cf::face::set_smooth $idx, $smooth;
3225 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3415 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3226 } else { 3416 } else {
3227 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3417 error "smooth face '$info->{smooth}' not found for face '$face'";
3228 } 3418 }
3229 3419
3230 cf::cede_to_tick; 3420 cf::cede_to_tick;
3231 } 3421 }
3232 } 3422 }
… …
3241 3431
3242 cf::anim::invalidate_all; # d'oh 3432 cf::anim::invalidate_all; # d'oh
3243 } 3433 }
3244 3434
3245 { 3435 {
3246 # TODO: for gcfclient pleasure, we should give resources
3247 # that gcfclient doesn't grok a >10000 face index.
3248 my $res = $facedata->{resource}; 3436 my $res = $facedata->{resource};
3249 3437
3250 while (my ($name, $info) = each %$res) { 3438 while (my ($name, $info) = each %$res) {
3251 if (defined $info->{type}) { 3439 if (defined $info->{type}) {
3252 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3440 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3253 my $data;
3254 3441
3255 if ($info->{type} & 1) { 3442 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3256 # prepend meta info
3257
3258 my $meta = $enc->encode ({
3259 name => $name,
3260 %{ $info->{meta} || {} },
3261 });
3262
3263 $data = pack "(w/a*)*", $meta, $info->{data};
3264 } else {
3265 $data = $info->{data};
3266 }
3267
3268 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3269 cf::face::set_type $idx, $info->{type}; 3443 cf::face::set_type $idx, $info->{type};
3270 } else { 3444 } else {
3271 $RESOURCE{$name} = $info; 3445 $RESOURCE{$name} = $info; # unused
3272 } 3446 }
3273 3447
3274 cf::cede_to_tick; 3448 cf::cede_to_tick;
3275 } 3449 }
3276 } 3450 }
3277 3451
3278 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3452 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3279 3453
3280 1 3454 1
3281} 3455}
3282
3283cf::global->attach (on_resource_update => sub {
3284 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3285 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3286
3287 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3288 my $sound = $soundconf->{compat}[$_]
3289 or next;
3290
3291 my $face = cf::face::find "sound/$sound->[1]";
3292 cf::sound::set $sound->[0] => $face;
3293 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3294 }
3295
3296 while (my ($k, $v) = each %{$soundconf->{event}}) {
3297 my $face = cf::face::find "sound/$v";
3298 cf::sound::set $k => $face;
3299 }
3300 }
3301});
3302 3456
3303register_exticmd fx_want => sub { 3457register_exticmd fx_want => sub {
3304 my ($ns, $want) = @_; 3458 my ($ns, $want) = @_;
3305 3459
3306 while (my ($k, $v) = each %$want) { 3460 while (my ($k, $v) = each %$want) {
3307 $ns->fx_want ($k, $v); 3461 $ns->fx_want ($k, $v);
3308 } 3462 }
3309}; 3463};
3464
3465sub load_resource_file($) {
3466 my $guard = lock_acquire "load_resource_file";
3467
3468 my $status = load_resource_file_ $_[0];
3469 get_slot 0.1, 100;
3470 cf::arch::commit_load;
3471
3472 $status
3473}
3310 3474
3311sub reload_regions { 3475sub reload_regions {
3312 # HACK to clear player env face cache, we need some signal framework 3476 # HACK to clear player env face cache, we need some signal framework
3313 # for this (global event?) 3477 # for this (global event?)
3314 %ext::player_env::MUSIC_FACE_CACHE = (); 3478 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3328} 3492}
3329 3493
3330sub reload_archetypes { 3494sub reload_archetypes {
3331 load_resource_file "$DATADIR/archetypes" 3495 load_resource_file "$DATADIR/archetypes"
3332 or die "unable to load archetypes\n"; 3496 or die "unable to load archetypes\n";
3333 #d# NEED to laod twice to resolve forward references
3334 # this really needs to be done in an extra post-pass
3335 # (which needs to be synchronous, so solve it differently)
3336 load_resource_file "$DATADIR/archetypes"
3337 or die "unable to load archetypes\n";
3338} 3497}
3339 3498
3340sub reload_treasures { 3499sub reload_treasures {
3341 load_resource_file "$DATADIR/treasures" 3500 load_resource_file "$DATADIR/treasures"
3342 or die "unable to load treasurelists\n"; 3501 or die "unable to load treasurelists\n";
3343} 3502}
3344 3503
3504sub reload_sound {
3505 trace "loading sound config from $DATADIR/sound\n";
3506
3507 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3508 or die "$DATADIR/sound $!";
3509
3510 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3511
3512 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3513 my $sound = $soundconf->{compat}[$_]
3514 or next;
3515
3516 my $face = cf::face::find "sound/$sound->[1]";
3517 cf::sound::set $sound->[0] => $face;
3518 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3519 }
3520
3521 while (my ($k, $v) = each %{$soundconf->{event}}) {
3522 my $face = cf::face::find "sound/$v";
3523 cf::sound::set $k => $face;
3524 }
3525}
3526
3345sub reload_resources { 3527sub reload_resources {
3346 warn "reloading resource files...\n"; 3528 trace "reloading resource files...\n";
3347 3529
3530 reload_facedata;
3531 reload_sound;
3532 reload_archetypes;
3348 reload_regions; 3533 reload_regions;
3349 reload_facedata;
3350 #reload_archetypes;#d#
3351 reload_archetypes;
3352 reload_treasures; 3534 reload_treasures;
3353 3535
3354 warn "finished reloading resource files\n"; 3536 trace "finished reloading resource files\n";
3355}
3356
3357sub init {
3358 reload_resources;
3359} 3537}
3360 3538
3361sub reload_config { 3539sub reload_config {
3540 trace "reloading config file...\n";
3541
3362 open my $fh, "<:utf8", "$CONFDIR/config" 3542 open my $fh, "<:utf8", "$CONFDIR/config"
3363 or return; 3543 or return;
3364 3544
3365 local $/; 3545 local $/;
3366 *CFG = YAML::Load <$fh>; 3546 *CFG = YAML::XS::Load scalar <$fh>;
3367 3547
3368 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3548 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3369 3549
3370 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3550 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3371 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3551 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3372 3552
3373 if (exists $CFG{mlockall}) { 3553 if (exists $CFG{mlockall}) {
… …
3375 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3555 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3376 and die "WARNING: m(un)lockall failed: $!\n"; 3556 and die "WARNING: m(un)lockall failed: $!\n";
3377 }; 3557 };
3378 warn $@ if $@; 3558 warn $@ if $@;
3379 } 3559 }
3560
3561 trace "finished reloading resource files\n";
3562}
3563
3564sub pidfile() {
3565 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3566 or die "$PIDFILE: $!";
3567 flock $fh, &Fcntl::LOCK_EX
3568 or die "$PIDFILE: flock: $!";
3569 $fh
3570}
3571
3572# make sure only one server instance is running at any one time
3573sub atomic {
3574 my $fh = pidfile;
3575
3576 my $pid = <$fh>;
3577 kill 9, $pid if $pid > 0;
3578
3579 seek $fh, 0, 0;
3580 print $fh $$;
3581}
3582
3583sub main_loop {
3584 trace "EV::loop starting\n";
3585 if (1) {
3586 EV::loop;
3587 }
3588 trace "EV::loop returned\n";
3589 goto &main_loop unless $REALLY_UNLOOP;
3380} 3590}
3381 3591
3382sub main { 3592sub main {
3593 cf::init_globals; # initialise logging
3594
3595 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3596 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3597 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3598 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3599
3600 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3601
3383 # we must not ever block the main coroutine 3602 # we must not ever block the main coroutine
3384 local $Coro::idle = sub { 3603 local $Coro::idle = sub {
3385 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3604 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3386 (async { 3605 (async {
3387 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3606 $Coro::current->{desc} = "IDLE BUG HANDLER";
3388 EV::loop EV::LOOP_ONESHOT; 3607 EV::loop EV::LOOP_ONESHOT;
3389 })->prio (Coro::PRIO_MAX); 3608 })->prio (Coro::PRIO_MAX);
3390 }; 3609 };
3391 3610
3392 reload_config;
3393 db_init;
3394 load_extensions;
3395
3396 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3397 evthread_start IO::AIO::poll_fileno; 3611 evthread_start IO::AIO::poll_fileno;
3398 EV::loop; 3612
3613 cf::sync_job {
3614 cf::incloader::init ();
3615
3616 cf::init_experience;
3617 cf::init_anim;
3618 cf::init_attackmess;
3619 cf::init_dynamic;
3620
3621 cf::load_settings;
3622 cf::load_materials;
3623
3624 reload_resources;
3625 reload_config;
3626 db_init;
3627
3628 cf::init_uuid;
3629 cf::init_signals;
3630 cf::init_skills;
3631
3632 cf::init_beforeplay;
3633
3634 atomic;
3635
3636 load_extensions;
3637
3638 utime time, time, $RUNTIMEFILE;
3639
3640 # no (long-running) fork's whatsoever before this point(!)
3641 use POSIX ();
3642 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3643
3644 (pop @POST_INIT)->(0) while @POST_INIT;
3645 };
3646
3647 cf::object::thawer::errors_are_fatal 0;
3648 info "parse errors in files are no longer fatal from this point on.\n";
3649
3650 my $free_main; $free_main = EV::idle sub {
3651 undef $free_main;
3652 undef &main; # free gobs of memory :)
3653 };
3654
3655 goto &main_loop;
3399} 3656}
3400 3657
3401############################################################################# 3658#############################################################################
3402# initialisation and cleanup 3659# initialisation and cleanup
3403 3660
3404# install some emergency cleanup handlers 3661# install some emergency cleanup handlers
3405BEGIN { 3662BEGIN {
3406 our %SIGWATCHER = (); 3663 our %SIGWATCHER = ();
3407 for my $signal (qw(INT HUP TERM)) { 3664 for my $signal (qw(INT HUP TERM)) {
3408 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3665 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3409 cf::cleanup "SIG$signal"; 3666 cf::cleanup "SIG$signal";
3410 }; 3667 };
3411 } 3668 }
3412} 3669}
3413 3670
3414sub write_runtime_sync { 3671sub write_runtime_sync {
3415 my $runtime = "$LOCALDIR/runtime"; 3672 my $t0 = AE::time;
3416 3673
3417 # first touch the runtime file to show we are still running: 3674 # first touch the runtime file to show we are still running:
3418 # the fsync below can take a very very long time. 3675 # the fsync below can take a very very long time.
3419 3676
3420 IO::AIO::aio_utime $runtime, undef, undef; 3677 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3421 3678
3422 my $guard = cf::lock_acquire "write_runtime"; 3679 my $guard = cf::lock_acquire "write_runtime";
3423 3680
3424 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3681 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3425 or return; 3682 or return;
3426 3683
3427 my $value = $cf::RUNTIME + 90 + 10; 3684 my $value = $cf::RUNTIME + 90 + 10;
3428 # 10 is the runtime save interval, for a monotonic clock 3685 # 10 is the runtime save interval, for a monotonic clock
3429 # 60 allows for the watchdog to kill the server. 3686 # 60 allows for the watchdog to kill the server.
… …
3439 aio_utime $fh, undef, undef; 3696 aio_utime $fh, undef, undef;
3440 3697
3441 close $fh 3698 close $fh
3442 or return; 3699 or return;
3443 3700
3444 aio_rename "$runtime~", $runtime 3701 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3445 and return; 3702 and return;
3446 3703
3447 warn "runtime file written.\n"; 3704 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3448 3705
3449 1 3706 1
3450} 3707}
3451 3708
3452our $uuid_lock; 3709our $uuid_lock;
… …
3461 my $uuid = "$LOCALDIR/uuid"; 3718 my $uuid = "$LOCALDIR/uuid";
3462 3719
3463 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644 3720 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3464 or return; 3721 or return;
3465 3722
3466 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur; 3723 my $value = uuid_seq uuid_cur;
3724
3725 unless ($value) {
3726 info "cowardly refusing to write zero uuid value!\n";
3727 return;
3728 }
3729
3730 my $value = uuid_str $value + $uuid_skip;
3467 $uuid_skip = 0; 3731 $uuid_skip = 0;
3468 3732
3469 (aio_write $fh, 0, (length $value), $value, 0) <= 0 3733 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3470 and return; 3734 and return;
3471 3735
… …
3477 or return; 3741 or return;
3478 3742
3479 aio_rename "$uuid~", $uuid 3743 aio_rename "$uuid~", $uuid
3480 and return; 3744 and return;
3481 3745
3482 warn "uuid file written ($value).\n"; 3746 trace "uuid file written ($value).\n";
3483 3747
3484 1 3748 1
3485 3749
3486} 3750}
3487 3751
… …
3493} 3757}
3494 3758
3495sub emergency_save() { 3759sub emergency_save() {
3496 my $freeze_guard = cf::freeze_mainloop; 3760 my $freeze_guard = cf::freeze_mainloop;
3497 3761
3498 warn "enter emergency perl save\n"; 3762 info "emergency_perl_save: enter\n";
3763
3764 # this is a trade-off: we want to be very quick here, so
3765 # save all maps without fsync, and later call a global sync
3766 # (which in turn might be very very slow)
3767 local $USE_FSYNC = 0;
3499 3768
3500 cf::sync_job { 3769 cf::sync_job {
3770 cf::write_runtime_sync; # external watchdog should not bark
3771
3501 # use a peculiar iteration method to avoid tripping on perl 3772 # use a peculiar iteration method to avoid tripping on perl
3502 # refcount bugs in for. also avoids problems with players 3773 # refcount bugs in for. also avoids problems with players
3503 # and maps saved/destroyed asynchronously. 3774 # and maps saved/destroyed asynchronously.
3504 warn "begin emergency player save\n"; 3775 info "emergency_perl_save: begin player save\n";
3505 for my $login (keys %cf::PLAYER) { 3776 for my $login (keys %cf::PLAYER) {
3506 my $pl = $cf::PLAYER{$login} or next; 3777 my $pl = $cf::PLAYER{$login} or next;
3507 $pl->valid or next; 3778 $pl->valid or next;
3508 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3779 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3509 $pl->save; 3780 $pl->save;
3510 } 3781 }
3511 warn "end emergency player save\n"; 3782 info "emergency_perl_save: end player save\n";
3512 3783
3513 warn "begin emergency map save\n"; 3784 cf::write_runtime_sync; # external watchdog should not bark
3785
3786 info "emergency_perl_save: begin map save\n";
3514 for my $path (keys %cf::MAP) { 3787 for my $path (keys %cf::MAP) {
3515 my $map = $cf::MAP{$path} or next; 3788 my $map = $cf::MAP{$path} or next;
3516 $map->valid or next; 3789 $map->valid or next;
3517 $map->save; 3790 $map->save;
3518 } 3791 }
3519 warn "end emergency map save\n"; 3792 info "emergency_perl_save: end map save\n";
3520 3793
3521 warn "begin emergency database checkpoint\n"; 3794 cf::write_runtime_sync; # external watchdog should not bark
3795
3796 info "emergency_perl_save: begin database checkpoint\n";
3522 BDB::db_env_txn_checkpoint $DB_ENV; 3797 BDB::db_env_txn_checkpoint $DB_ENV;
3523 warn "end emergency database checkpoint\n"; 3798 info "emergency_perl_save: end database checkpoint\n";
3524 3799
3525 warn "begin write uuid\n"; 3800 info "emergency_perl_save: begin write uuid\n";
3526 write_uuid_sync 1; 3801 write_uuid_sync 1;
3527 warn "end write uuid\n"; 3802 info "emergency_perl_save: end write uuid\n";
3803
3804 cf::write_runtime_sync; # external watchdog should not bark
3805
3806 trace "emergency_perl_save: syncing database to disk";
3807 BDB::db_env_txn_checkpoint $DB_ENV;
3808
3809 info "emergency_perl_save: starting sync\n";
3810 IO::AIO::aio_sync sub {
3811 info "emergency_perl_save: finished sync\n";
3812 };
3813
3814 cf::write_runtime_sync; # external watchdog should not bark
3815
3816 trace "emergency_perl_save: flushing outstanding aio requests";
3817 while (IO::AIO::nreqs || BDB::nreqs) {
3818 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3819 }
3820
3821 cf::write_runtime_sync; # external watchdog should not bark
3528 }; 3822 };
3529 3823
3530 warn "leave emergency perl save\n"; 3824 info "emergency_perl_save: leave\n";
3531} 3825}
3532 3826
3533sub post_cleanup { 3827sub post_cleanup {
3534 my ($make_core) = @_; 3828 my ($make_core) = @_;
3535 3829
3830 IO::AIO::flush;
3831
3536 warn Carp::longmess "post_cleanup backtrace" 3832 error Carp::longmess "post_cleanup backtrace"
3537 if $make_core; 3833 if $make_core;
3834
3835 my $fh = pidfile;
3836 unlink $PIDFILE if <$fh> == $$;
3837}
3838
3839# a safer delete_package, copied from Symbol
3840sub clear_package($) {
3841 my $pkg = shift;
3842
3843 # expand to full symbol table name if needed
3844 unless ($pkg =~ /^main::.*::$/) {
3845 $pkg = "main$pkg" if $pkg =~ /^::/;
3846 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3847 $pkg .= '::' unless $pkg =~ /::$/;
3848 }
3849
3850 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3851 my $stem_symtab = *{$stem}{HASH};
3852
3853 defined $stem_symtab and exists $stem_symtab->{$leaf}
3854 or return;
3855
3856 # clear all symbols
3857 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3858 for my $name (keys %$leaf_symtab) {
3859 _gv_clear *{"$pkg$name"};
3860# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3861 }
3538} 3862}
3539 3863
3540sub do_reload_perl() { 3864sub do_reload_perl() {
3541 # can/must only be called in main 3865 # can/must only be called in main
3542 if ($Coro::current != $Coro::main) { 3866 unless (in_main) {
3543 warn "can only reload from main coroutine"; 3867 error "can only reload from main coroutine";
3544 return; 3868 return;
3545 } 3869 }
3546 3870
3871 return if $RELOAD++;
3872
3873 my $t1 = AE::time;
3874
3875 while ($RELOAD) {
3876 cf::get_slot 0.1, -1, "reload_perl";
3547 warn "reloading..."; 3877 info "reloading...";
3548 3878
3549 warn "entering sync_job"; 3879 trace "entering sync_job";
3550 3880
3551 cf::sync_job { 3881 cf::sync_job {
3552 cf::write_runtime_sync; # external watchdog should not bark
3553 cf::emergency_save; 3882 #cf::emergency_save;
3554 cf::write_runtime_sync; # external watchdog should not bark
3555 3883
3556 warn "syncing database to disk";
3557 BDB::db_env_txn_checkpoint $DB_ENV;
3558
3559 # if anything goes wrong in here, we should simply crash as we already saved
3560
3561 warn "flushing outstanding aio requests";
3562 for (;;) {
3563 BDB::flush;
3564 IO::AIO::flush;
3565 Coro::cede_notself;
3566 last unless IO::AIO::nreqs || BDB::nreqs;
3567 warn "iterate...";
3568 }
3569
3570 ++$RELOAD;
3571
3572 warn "cancelling all extension coros"; 3884 trace "cancelling all extension coros";
3573 $_->cancel for values %EXT_CORO; 3885 $_->cancel for values %EXT_CORO;
3574 %EXT_CORO = (); 3886 %EXT_CORO = ();
3575 3887
3576 warn "removing commands"; 3888 trace "removing commands";
3577 %COMMAND = (); 3889 %COMMAND = ();
3578 3890
3579 warn "removing ext/exti commands"; 3891 trace "removing ext/exti commands";
3580 %EXTCMD = (); 3892 %EXTCMD = ();
3581 %EXTICMD = (); 3893 %EXTICMD = ();
3582 3894
3583 warn "unloading/nuking all extensions"; 3895 trace "unloading/nuking all extensions";
3584 for my $pkg (@EXTS) { 3896 for my $pkg (@EXTS) {
3585 warn "... unloading $pkg"; 3897 trace "... unloading $pkg";
3586 3898
3587 if (my $cb = $pkg->can ("unload")) { 3899 if (my $cb = $pkg->can ("unload")) {
3588 eval { 3900 eval {
3589 $cb->($pkg); 3901 $cb->($pkg);
3590 1 3902 1
3591 } or warn "$pkg unloaded, but with errors: $@"; 3903 } or error "$pkg unloaded, but with errors: $@";
3904 }
3905
3906 trace "... clearing $pkg";
3907 clear_package $pkg;
3592 } 3908 }
3593 3909
3594 warn "... nuking $pkg";
3595 Symbol::delete_package $pkg;
3596 }
3597
3598 warn "unloading all perl modules loaded from $LIBDIR"; 3910 trace "unloading all perl modules loaded from $LIBDIR";
3599 while (my ($k, $v) = each %INC) { 3911 while (my ($k, $v) = each %INC) {
3600 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3912 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3601 3913
3602 warn "... unloading $k"; 3914 trace "... unloading $k";
3603 delete $INC{$k}; 3915 delete $INC{$k};
3604 3916
3605 $k =~ s/\.pm$//; 3917 $k =~ s/\.pm$//;
3606 $k =~ s/\//::/g; 3918 $k =~ s/\//::/g;
3607 3919
3608 if (my $cb = $k->can ("unload_module")) { 3920 if (my $cb = $k->can ("unload_module")) {
3609 $cb->(); 3921 $cb->();
3922 }
3923
3924 clear_package $k;
3610 } 3925 }
3611 3926
3612 Symbol::delete_package $k;
3613 }
3614
3615 warn "getting rid of safe::, as good as possible"; 3927 trace "getting rid of safe::, as good as possible";
3616 Symbol::delete_package "safe::$_" 3928 clear_package "safe::$_"
3617 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3929 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3618 3930
3619 warn "unloading cf.pm \"a bit\""; 3931 trace "unloading cf.pm \"a bit\"";
3620 delete $INC{"cf.pm"}; 3932 delete $INC{"cf.pm"};
3621 delete $INC{"cf/pod.pm"}; 3933 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3622 3934
3623 # don't, removes xs symbols, too, 3935 # don't, removes xs symbols, too,
3624 # and global variables created in xs 3936 # and global variables created in xs
3625 #Symbol::delete_package __PACKAGE__; 3937 #clear_package __PACKAGE__;
3626 3938
3627 warn "unload completed, starting to reload now"; 3939 info "unload completed, starting to reload now";
3628 3940
3629 warn "reloading cf.pm"; 3941 trace "reloading cf.pm";
3630 require cf; 3942 require cf;
3631 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3943 cf::_connect_to_perl_1;
3632 3944
3633 warn "loading config and database again"; 3945 trace "loading config and database again";
3634 cf::reload_config; 3946 cf::reload_config;
3635 3947
3636 warn "loading extensions"; 3948 trace "loading extensions";
3637 cf::load_extensions; 3949 cf::load_extensions;
3638 3950
3951 if ($REATTACH_ON_RELOAD) {
3639 warn "reattaching attachments to objects/players"; 3952 trace "reattaching attachments to objects/players";
3640 _global_reattach; # objects, sockets 3953 _global_reattach; # objects, sockets
3641 warn "reattaching attachments to maps"; 3954 trace "reattaching attachments to maps";
3642 reattach $_ for values %MAP; 3955 reattach $_ for values %MAP;
3643 warn "reattaching attachments to players"; 3956 trace "reattaching attachments to players";
3644 reattach $_ for values %PLAYER; 3957 reattach $_ for values %PLAYER;
3958 }
3645 3959
3960 trace "running post_init jobs";
3961 (pop @POST_INIT)->(1) while @POST_INIT;
3962
3646 warn "leaving sync_job"; 3963 trace "leaving sync_job";
3647 3964
3648 1 3965 1
3649 } or do { 3966 } or do {
3650 warn $@; 3967 error $@;
3651 cf::cleanup "error while reloading, exiting."; 3968 cf::cleanup "error while reloading, exiting.";
3969 };
3970
3971 info "reloaded";
3972 --$RELOAD;
3652 }; 3973 }
3653 3974
3654 warn "reloaded"; 3975 $t1 = AE::time - $t1;
3976 info "reload completed in ${t1}s\n";
3655}; 3977};
3656 3978
3657our $RELOAD_WATCHER; # used only during reload 3979our $RELOAD_WATCHER; # used only during reload
3658 3980
3659sub reload_perl() { 3981sub reload_perl() {
3660 # doing reload synchronously and two reloads happen back-to-back, 3982 # doing reload synchronously and two reloads happen back-to-back,
3661 # coro crashes during coro_state_free->destroy here. 3983 # coro crashes during coro_state_free->destroy here.
3662 3984
3985 $RELOAD_WATCHER ||= cf::async {
3986 Coro::AIO::aio_wait cache_extensions;
3987
3663 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 3988 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3664 do_reload_perl; 3989 do_reload_perl;
3665 undef $RELOAD_WATCHER; 3990 undef $RELOAD_WATCHER;
3991 };
3666 }; 3992 };
3667} 3993}
3668 3994
3669register_command "reload" => sub { 3995register_command "reload" => sub {
3670 my ($who, $arg) = @_; 3996 my ($who, $arg) = @_;
… …
3676 reload_perl; 4002 reload_perl;
3677 }; 4003 };
3678 } 4004 }
3679}; 4005};
3680 4006
3681unshift @INC, $LIBDIR; 4007#############################################################################
3682 4008
3683my $bug_warning = 0; 4009my $bug_warning = 0;
3684 4010
3685our @WAIT_FOR_TICK; 4011our @WAIT_FOR_TICK;
3686our @WAIT_FOR_TICK_BEGIN; 4012our @WAIT_FOR_TICK_BEGIN;
3687 4013
3688sub wait_for_tick { 4014sub wait_for_tick {
3689 return if tick_inhibit;
3690 return if $Coro::current == $Coro::main; 4015 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3691 4016
3692 my $signal = new Coro::Signal; 4017 my $signal = new Coro::Signal;
3693 push @WAIT_FOR_TICK, $signal; 4018 push @WAIT_FOR_TICK, $signal;
3694 $signal->wait; 4019 $signal->wait;
3695} 4020}
3696 4021
3697sub wait_for_tick_begin { 4022sub wait_for_tick_begin {
3698 return if tick_inhibit;
3699 return if $Coro::current == $Coro::main; 4023 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3700 4024
3701 my $signal = new Coro::Signal; 4025 my $signal = new Coro::Signal;
3702 push @WAIT_FOR_TICK_BEGIN, $signal; 4026 push @WAIT_FOR_TICK_BEGIN, $signal;
3703 $signal->wait; 4027 $signal->wait;
3704} 4028}
… …
3710 return; 4034 return;
3711 } 4035 }
3712 4036
3713 cf::server_tick; # one server iteration 4037 cf::server_tick; # one server iteration
3714 4038
4039 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
4040
3715 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4041 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3716 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4042 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3717 Coro::async_pool { 4043 Coro::async_pool {
3718 $Coro::current->{desc} = "runtime saver"; 4044 $Coro::current->{desc} = "runtime saver";
3719 write_runtime_sync 4045 write_runtime_sync
3720 or warn "ERROR: unable to write runtime file: $!"; 4046 or error "ERROR: unable to write runtime file: $!";
3721 }; 4047 };
3722 } 4048 }
3723 4049
3724 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4050 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3725 $sig->send; 4051 $sig->send;
… …
3733 4059
3734 if (0) { 4060 if (0) {
3735 if ($NEXT_TICK) { 4061 if ($NEXT_TICK) {
3736 my $jitter = $TICK_START - $NEXT_TICK; 4062 my $jitter = $TICK_START - $NEXT_TICK;
3737 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4063 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3738 warn "jitter $JITTER\n";#d# 4064 debug "jitter $JITTER\n";#d#
3739 } 4065 }
3740 } 4066 }
3741} 4067}
3742 4068
3743{ 4069{
3744 # configure BDB 4070 # configure BDB
3745 4071
3746 BDB::min_parallel 8; 4072 BDB::min_parallel 16;
3747 BDB::max_poll_reqs $TICK * 0.1; 4073 BDB::max_poll_reqs $TICK * 0.1;
3748 $Coro::BDB::WATCHER->priority (1); 4074 $AnyEvent::BDB::WATCHER->priority (1);
3749 4075
3750 unless ($DB_ENV) { 4076 unless ($DB_ENV) {
3751 $DB_ENV = BDB::db_env_create; 4077 $DB_ENV = BDB::db_env_create;
3752 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 4078 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3753 | BDB::LOG_AUTOREMOVE, 1); 4079 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4080 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3754 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 4081 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3755 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 4082 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3756 4083
3757 cf::sync_job { 4084 cf::sync_job {
3758 eval { 4085 eval {
… …
3784{ 4111{
3785 # configure IO::AIO 4112 # configure IO::AIO
3786 4113
3787 IO::AIO::min_parallel 8; 4114 IO::AIO::min_parallel 8;
3788 IO::AIO::max_poll_time $TICK * 0.1; 4115 IO::AIO::max_poll_time $TICK * 0.1;
3789 $Coro::AIO::WATCHER->priority (1); 4116 undef $AnyEvent::AIO::WATCHER;
3790} 4117}
3791 4118
3792my $_log_backtrace; 4119my $_log_backtrace;
3793 4120
3794sub _log_backtrace { 4121sub _log_backtrace {
… …
3797 $msg =~ s/\n//; 4124 $msg =~ s/\n//;
3798 4125
3799 # limit the # of concurrent backtraces 4126 # limit the # of concurrent backtraces
3800 if ($_log_backtrace < 2) { 4127 if ($_log_backtrace < 2) {
3801 ++$_log_backtrace; 4128 ++$_log_backtrace;
4129 my $perl_bt = Carp::longmess $msg;
3802 async { 4130 async {
3803 $Coro::current->{desc} = "abt $msg"; 4131 $Coro::current->{desc} = "abt $msg";
3804 4132
3805 my @bt = fork_call { 4133 my @bt = fork_call {
3806 @addr = map { sprintf "%x", $_ } @addr; 4134 @addr = map { sprintf "%x", $_ } @addr;
… …
3817 } 4145 }
3818 4146
3819 @funcs 4147 @funcs
3820 }; 4148 };
3821 4149
3822 LOG llevInfo, "[ABT] $msg\n"; 4150 LOG llevInfo, "[ABT] $perl_bt\n";
4151 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3823 LOG llevInfo, "[ABT] $_\n" for @bt; 4152 LOG llevInfo, "[ABT] $_\n" for @bt;
3824 --$_log_backtrace; 4153 --$_log_backtrace;
3825 }; 4154 };
3826 } else { 4155 } else {
3827 LOG llevInfo, "[ABT] $msg\n"; 4156 LOG llevInfo, "[ABT] $msg\n";
3828 LOG llevInfo, "[ABT] [suppressed]\n"; 4157 LOG llevInfo, "[ABT] [suppressed]\n";
3829 } 4158 }
3830} 4159}
3831 4160
3832# load additional modules 4161# load additional modules
3833use cf::pod; 4162require "cf/$_.pm" for @EXTRA_MODULES;
4163cf::_connect_to_perl_2;
3834 4164
3835END { cf::emergency_save } 4165END { cf::emergency_save }
3836 4166
38371 41671
3838 4168

Diff Legend

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