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.411 by root, Fri Feb 1 15:54:07 2008 UTC vs.
Revision 1.534 by root, Thu Apr 29 08:13:51 2010 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
25use 5.10.0;
3use utf8; 26use utf8;
4use strict; 27use strict qw(vars subs);
5 28
6use Symbol; 29use Symbol;
7use List::Util; 30use List::Util;
8use Socket; 31use Socket;
9use EV 1.86; 32use EV;
10use Opcode; 33use Opcode;
11use Safe; 34use Safe;
12use Safe::Hole; 35use Safe::Hole;
13use Storable (); 36use Storable ();
37use Carp ();
14 38
39use Guard ();
15use Coro 4.32 (); 40use Coro ();
16use Coro::State; 41use Coro::State;
17use Coro::Handle; 42use Coro::Handle;
18use Coro::EV; 43use Coro::EV;
44use Coro::AnyEvent;
19use Coro::Timer; 45use Coro::Timer;
20use Coro::Signal; 46use Coro::Signal;
21use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
22use Coro::AIO; 50use Coro::AIO;
23use Coro::BDB; 51use Coro::BDB 1.6;
24use Coro::Storable; 52use Coro::Storable;
25use Coro::Util (); 53use Coro::Util ();
26 54
27use JSON::XS 2.01 (); 55use JSON::XS 2.01 ();
28use BDB (); 56use BDB ();
29use Data::Dumper; 57use Data::Dumper;
30use Digest::MD5;
31use Fcntl; 58use Fcntl;
32use YAML (); 59use YAML::XS ();
33use IO::AIO 2.51 (); 60use IO::AIO ();
34use Time::HiRes; 61use Time::HiRes;
35use Compress::LZF; 62use Compress::LZF;
36use Digest::MD5 (); 63use Digest::MD5 ();
64
65AnyEvent::detect;
37 66
38# configure various modules to our taste 67# configure various modules to our taste
39# 68#
40$Storable::canonical = 1; # reduce rsync transfers 69$Storable::canonical = 1; # reduce rsync transfers
41Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 70Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
71
72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
73
74# make sure c-lzf reinitialises itself
75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
42Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
43 77
44$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 78# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
45 80
46sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
47 82
48our %COMMAND = (); 83our %COMMAND = ();
49our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
… …
52our %EXTCMD = (); 87our %EXTCMD = ();
53our %EXTICMD = (); 88our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
56 91
57our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
58our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
59 96
60our $CONFDIR = confdir; 97our $CONFDIR = confdir;
61our $DATADIR = datadir; 98our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir; 101our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir; 102our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir; 103our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir; 105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
71our %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;
72 118
73our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
74our $TICK_WATCHER;
75our $AIO_POLL_WATCHER;
76our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
77our $NEXT_TICK; 121our $NEXT_TICK;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 122our $USE_FSYNC = 1; # use fsync to write maps - default on
79 123
80our $BDB_POLL_WATCHER;
81our $BDB_DEADLOCK_WATCHER; 124our $BDB_DEADLOCK_WATCHER;
82our $BDB_CHECKPOINT_WATCHER; 125our $BDB_CHECKPOINT_WATCHER;
83our $BDB_TRICKLE_WATCHER; 126our $BDB_TRICKLE_WATCHER;
84our $DB_ENV; 127our $DB_ENV;
85 128
129our @EXTRA_MODULES = qw(pod match mapscript);
130
86our %CFG; 131our %CFG;
87 132
88our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
89our $RUNTIME; 134our $RUNTIME;
90our $NOW; 135our $NOW;
… …
96# used to convert map paths into valid unix filenames by replacing / by ∕ 141# used to convert map paths into valid unix filenames by replacing / by ∕
97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 142our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98 143
99our $LOAD; # a number between 0 (idle) and 1 (too many objects) 144our $LOAD; # a number between 0 (idle) and 1 (too many objects)
100our $LOADAVG; # same thing, but with alpha-smoothing 145our $LOADAVG; # same thing, but with alpha-smoothing
146our $JITTER; # average jitter
101our $tick_start; # for load detecting purposes 147our $TICK_START; # for load detecting purposes
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 :)
102 153
103binmode STDOUT; 154binmode STDOUT;
104binmode STDERR; 155binmode STDERR;
105 156
106# read virtual server time, if available 157# read virtual server time, if available
107unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 158unless ($RUNTIME || !-e $RUNTIMEFILE) {
108 open my $fh, "<", "$LOCALDIR/runtime" 159 open my $fh, "<", $RUNTIMEFILE
109 or die "unable to read runtime file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
110 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
111} 162}
163
164eval "sub TICK() { $TICK } 1" or die;
112 165
113mkdir $_ 166mkdir $_
114 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
115 168
116our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
117 170
118sub 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::"} };
119 187
120############################################################################# 188#############################################################################
121 189
122=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
123 191
… …
170returns 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
171per 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.
172 240
173=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
174 242
175This array contains the results of the last C<invoke ()> call. When 243This array contains the results of the last C<invoke ()> call. When
176C<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
177that call. 245that call.
178 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
179=back 253=back
180 254
181=cut 255=cut
182 256
183BEGIN { 257sub error(@) { LOG llevError, join "", @_ }
184 *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 {
185 my $msg = join "", @_; 264 my $msg = join "", @_;
186 265
187 $msg .= "\n" 266 $msg .= "\n"
188 unless $msg =~ /\n$/; 267 unless $msg =~ /\n$/;
189 268
190 $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;
191 270
192 LOG llevError, $msg; 271 LOG llevWarn, $msg;
193 }; 272};
194}
195 273
196$Coro::State::DIEHOOK = sub { 274$Coro::State::DIEHOOK = sub {
197 return unless $^S eq 0; # "eq", not "==" 275 return unless $^S eq 0; # "eq", not "=="
198 276
199 if ($Coro::current == $Coro::main) {#d# 277 error Carp::longmess $_[0];
278
279 if (in_main) {#d#
200 warn "DIEHOOK called in main context, Coro bug?\n";#d# 280 error "DIEHOOK called in main context, Coro bug?\n";#d#
201 return;#d# 281 return;#d#
202 }#d# 282 }#d#
203 283
204 # kill coroutine otherwise 284 # kill coroutine otherwise
205 warn Carp::longmess $_[0];
206 Coro::terminate 285 Coro::terminate
207}; 286};
208
209$SIG{__DIE__} = sub { }; #d#?
210 287
211@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 288@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
212@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 289@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
213@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 290@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
214@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 291@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
221for my $pkg (qw( 298for my $pkg (qw(
222 cf::global cf::attachable 299 cf::global cf::attachable
223 cf::object cf::object::player 300 cf::object cf::object::player
224 cf::client cf::player 301 cf::client cf::player
225 cf::arch cf::living 302 cf::arch cf::living
303 cf::map cf::mapspace
226 cf::map cf::party cf::region 304 cf::party cf::region
227)) { 305)) {
228 no strict 'refs';
229 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 306 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
230} 307}
231 308
232$EV::DIED = sub { 309$EV::DIED = sub {
233 warn "error in event callback: @_"; 310 Carp::cluck "error in event callback: @_";
234}; 311};
235 312
236############################################################################# 313#############################################################################
237 314
238=head2 UTILITY FUNCTIONS 315=head2 UTILITY FUNCTIONS
… …
275our $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
276 353
277sub encode_json($) { $json_coder->encode ($_[0]) } 354sub encode_json($) { $json_coder->encode ($_[0]) }
278sub decode_json($) { $json_coder->decode ($_[0]) } 355sub decode_json($) { $json_coder->decode ($_[0]) }
279 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
280=item cf::lock_wait $string 371=item cf::lock_wait $string
281 372
282Wait until the given lock is available. See cf::lock_acquire. 373Wait until the given lock is available. See cf::lock_acquire.
283 374
284=item my $lock = cf::lock_acquire $string 375=item my $lock = cf::lock_acquire $string
285 376
286Wait 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
287a 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,
288for example when the coroutine gets canceled), the lock is automatically 379for example when the coroutine gets canceled), the lock is automatically
289returned. 380returned.
290 381
291Locks 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
292deadlocked coro. 383deadlocked coro.
… …
298 389
299Return 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.
300 391
301=cut 392=cut
302 393
303our %LOCK; 394our $LOCKS = new Coro::SemaphoreSet;
304our %LOCKER;#d#
305 395
306sub lock_wait($) { 396sub lock_wait($) {
307 my ($key) = @_; 397 $LOCKS->wait ($_[0]);
308
309 if ($LOCKER{$key} == $Coro::current) {#d#
310 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
311 return;#d#
312 }#d#
313
314 # wait for lock, if any
315 while ($LOCK{$key}) {
316 push @{ $LOCK{$key} }, $Coro::current;
317 Coro::schedule;
318 }
319} 398}
320 399
321sub lock_acquire($) { 400sub lock_acquire($) {
322 my ($key) = @_; 401 $LOCKS->guard ($_[0])
323
324 # wait, to be sure we are not locked
325 lock_wait $key;
326
327 $LOCK{$key} = [];
328 $LOCKER{$key} = $Coro::current;#d#
329
330 Coro::guard {
331 delete $LOCKER{$key};#d#
332 # wake up all waiters, to be on the safe side
333 $_->ready for @{ delete $LOCK{$key} };
334 }
335} 402}
336 403
337sub lock_active($) { 404sub lock_active($) {
338 my ($key) = @_; 405 $LOCKS->count ($_[0]) < 1
339
340 ! ! $LOCK{$key}
341} 406}
342 407
343sub freeze_mainloop { 408sub freeze_mainloop {
344 return unless $TICK_WATCHER->is_active; 409 tick_inhibit_inc;
345 410
346 my $guard = Coro::guard { 411 &Guard::guard (\&tick_inhibit_dec);
347 $TICK_WATCHER->start;
348 };
349 $TICK_WATCHER->stop;
350 $guard
351} 412}
352 413
353=item cf::periodic $interval, $cb 414=item cf::periodic $interval, $cb
354 415
355Like 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
356get spread over timer. 417get spread over time.
357 418
358=cut 419=cut
359 420
360sub periodic($$) { 421sub periodic($$) {
361 my ($interval, $cb) = @_; 422 my ($interval, $cb) = @_;
… …
378 439
379=cut 440=cut
380 441
381our @SLOT_QUEUE; 442our @SLOT_QUEUE;
382our $SLOT_QUEUE; 443our $SLOT_QUEUE;
444our $SLOT_DECAY = 0.9;
383 445
384$SLOT_QUEUE->cancel if $SLOT_QUEUE; 446$SLOT_QUEUE->cancel if $SLOT_QUEUE;
385$SLOT_QUEUE = Coro::async { 447$SLOT_QUEUE = Coro::async {
386 $Coro::current->desc ("timeslot manager"); 448 $Coro::current->desc ("timeslot manager");
387 449
388 my $signal = new Coro::Signal; 450 my $signal = new Coro::Signal;
451 my $busy;
389 452
390 while () { 453 while () {
391 next_job: 454 next_job:
455
392 my $avail = cf::till_tick; 456 my $avail = cf::till_tick;
393 if ($avail > 0.01) { 457
394 for (0 .. $#SLOT_QUEUE) { 458 for (0 .. $#SLOT_QUEUE) {
395 if ($SLOT_QUEUE[$_][0] < $avail) { 459 if ($SLOT_QUEUE[$_][0] <= $avail) {
460 $busy = 0;
396 my $job = splice @SLOT_QUEUE, $_, 1, (); 461 my $job = splice @SLOT_QUEUE, $_, 1, ();
397 $job->[2]->send; 462 $job->[2]->send;
398 Coro::cede; 463 Coro::cede;
399 goto next_job; 464 goto next_job;
400 } 465 } else {
466 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
401 } 467 }
402 } 468 }
403 469
404 if (@SLOT_QUEUE) { 470 if (@SLOT_QUEUE) {
405 # 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
406 push @cf::WAIT_FOR_TICK, $signal; 472 push @cf::WAIT_FOR_TICK, $signal;
407 $signal->wait; 473 $signal->wait;
408 } else { 474 } else {
475 $busy = 0;
409 Coro::schedule; 476 Coro::schedule;
410 } 477 }
411 } 478 }
412}; 479};
413 480
414sub get_slot($;$$) { 481sub get_slot($;$$) {
482 return if tick_inhibit || $Coro::current == $Coro::main;
483
415 my ($time, $pri, $name) = @_; 484 my ($time, $pri, $name) = @_;
416 485
417 $time = $TICK * .6 if $time > $TICK * .6; 486 $time = clamp $time, 0.01, $TICK * .6;
487
418 my $sig = new Coro::Signal; 488 my $sig = new Coro::Signal;
419 489
420 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 490 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
421 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 491 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
422 $SLOT_QUEUE->ready; 492 $SLOT_QUEUE->ready;
… …
448=cut 518=cut
449 519
450sub sync_job(&) { 520sub sync_job(&) {
451 my ($job) = @_; 521 my ($job) = @_;
452 522
453 if ($Coro::current == $Coro::main) { 523 if (in_main) {
454 my $time = EV::time; 524 my $time = AE::time;
455 525
456 # this is the main coro, too bad, we have to block 526 # this is the main coro, too bad, we have to block
457 # till the operation succeeds, freezing the server :/ 527 # till the operation succeeds, freezing the server :/
458 528
459 LOG llevError, Carp::longmess "sync job";#d# 529 #LOG llevError, Carp::longmess "sync job";#d#
460 530
461 # TODO: use suspend/resume instead
462 # (but this is cancel-safe)
463 my $freeze_guard = freeze_mainloop; 531 my $freeze_guard = freeze_mainloop;
464 532
465 my $busy = 1; 533 my $busy = 1;
466 my @res; 534 my @res;
467 535
468 (async { 536 (async {
469 $Coro::current->desc ("sync job coro"); 537 $Coro::current->desc ("sync job coro");
470 @res = eval { $job->() }; 538 @res = eval { $job->() };
471 warn $@ if $@; 539 error $@ if $@;
472 undef $busy; 540 undef $busy;
473 })->prio (Coro::PRIO_MAX); 541 })->prio (Coro::PRIO_MAX);
474 542
475 while ($busy) { 543 while ($busy) {
476 if (Coro::nready) { 544 if (Coro::nready) {
… …
478 } else { 546 } else {
479 EV::loop EV::LOOP_ONESHOT; 547 EV::loop EV::LOOP_ONESHOT;
480 } 548 }
481 } 549 }
482 550
483 $time = EV::time - $time; 551 my $time = AE::time - $time;
484 552
485 LOG llevError | logBacktrace, Carp::longmess "long sync job"
486 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
487
488 $tick_start += $time; # do not account sync jobs to server load 553 $TICK_START += $time; # do not account sync jobs to server load
489 554
490 wantarray ? @res : $res[0] 555 wantarray ? @res : $res[0]
491 } else { 556 } else {
492 # we are in another coroutine, how wonderful, everything just works 557 # we are in another coroutine, how wonderful, everything just works
493 558
… …
537 }, @args; 602 }, @args;
538 603
539 wantarray ? @res : $res[-1] 604 wantarray ? @res : $res[-1]
540} 605}
541 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 )
616}
617
618=item $coin = coin_from_name $name
619
620=cut
621
622our %coin_alias = (
623 "silver" => "silvercoin",
624 "silvercoin" => "silvercoin",
625 "silvercoins" => "silvercoin",
626 "gold" => "goldcoin",
627 "goldcoin" => "goldcoin",
628 "goldcoins" => "goldcoin",
629 "platinum" => "platinacoin",
630 "platinumcoin" => "platinacoin",
631 "platinumcoins" => "platinacoin",
632 "platina" => "platinacoin",
633 "platinacoin" => "platinacoin",
634 "platinacoins" => "platinacoin",
635 "royalty" => "royalty",
636 "royalties" => "royalty",
637);
638
639sub coin_from_name($) {
640 $coin_alias{$_[0]}
641 ? cf::arch::find $coin_alias{$_[0]}
642 : undef
643}
644
542=item $value = cf::db_get $family => $key 645=item $value = cf::db_get $family => $key
543 646
544Returns a single value from the environment database. 647Returns a single value from the environment database.
545 648
546=item cf::db_put $family => $key => $value 649=item cf::db_put $family => $key => $value
… …
554within each server. 657within each server.
555 658
556=cut 659=cut
557 660
558sub db_table($) { 661sub db_table($) {
662 cf::error "db_get called from main context"
663 if $Coro::current == $Coro::main;
664
559 my ($name) = @_; 665 my ($name) = @_;
560 my $db = BDB::db_create $DB_ENV; 666 my $db = BDB::db_create $DB_ENV;
561 667
562 eval { 668 eval {
563 $db->set_flags (BDB::CHKSUM); 669 $db->set_flags (BDB::CHKSUM);
… …
573} 679}
574 680
575our $DB; 681our $DB;
576 682
577sub db_init { 683sub db_init {
578 cf::sync_job {
579 $DB ||= db_table "db"; 684 $DB ||= db_table "db";
580 };
581} 685}
582 686
583sub db_get($$) { 687sub db_get($$) {
584 my $key = "$_[0]/$_[1]"; 688 my $key = "$_[0]/$_[1]";
585 689
586 cf::sync_job { 690 cf::error "db_get called from main context"
691 if $Coro::current == $Coro::main;
692
587 BDB::db_get $DB, undef, $key, my $data; 693 BDB::db_get $DB, undef, $key, my $data;
588 694
589 $! ? () 695 $! ? ()
590 : $data 696 : $data
591 }
592} 697}
593 698
594sub db_put($$$) { 699sub db_put($$$) {
595 BDB::dbreq_pri 4; 700 BDB::dbreq_pri 4;
596 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 701 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
652 757
653 my $t1 = Time::HiRes::time; 758 my $t1 = Time::HiRes::time;
654 my $data = $process->(\@data); 759 my $data = $process->(\@data);
655 my $t2 = Time::HiRes::time; 760 my $t2 = Time::HiRes::time;
656 761
657 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 762 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
658 763
659 db_put cache => "$id/data", $data; 764 db_put cache => "$id/data", $data;
660 db_put cache => "$id/md5" , $md5; 765 db_put cache => "$id/md5" , $md5;
661 db_put cache => "$id/meta", $meta; 766 db_put cache => "$id/meta", $meta;
662 767
… …
672 777
673=cut 778=cut
674 779
675sub datalog($@) { 780sub datalog($@) {
676 my ($type, %kv) = @_; 781 my ($type, %kv) = @_;
677 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 782 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
678} 783}
679 784
680=back 785=back
681 786
682=cut 787=cut
683 788
684############################################################################# 789#############################################################################
685 790
686=head2 ATTACHABLE OBJECTS 791=head2 ATTACHABLE OBJECTS
687 792
688Many 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
689attach callbacks/event handlers (a collection of which is called an "attachment") 794attach callbacks/event handlers (a collection of which is called an "attachment")
690to it. All such attachable objects support the following methods. 795to it. All such attachable objects support the following methods.
691 796
692In 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>
693C<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
… …
743=item cf::CLASS::attachment $name, ... 848=item cf::CLASS::attachment $name, ...
744 849
745Register an attachment by C<$name> through which attachable objects of the 850Register an attachment by C<$name> through which attachable objects of the
746given CLASS can refer to this attachment. 851given CLASS can refer to this attachment.
747 852
748Some classes such as crossfire maps and objects can specify attachments 853Some classes such as deliantra maps and objects can specify attachments
749that 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.
750 855
751These calls expect any number of the following handler/hook descriptions: 856These calls expect any number of the following handler/hook descriptions:
752 857
753=over 4 858=over 4
… …
877 982
878 } elsif (exists $cb_id{$type}) { 983 } elsif (exists $cb_id{$type}) {
879 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 984 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
880 985
881 } elsif (ref $type) { 986 } elsif (ref $type) {
882 warn "attaching objects not supported, ignoring.\n"; 987 error "attaching objects not supported, ignoring.\n";
883 988
884 } else { 989 } else {
885 shift @arg; 990 shift @arg;
886 warn "attach argument '$type' not supported, ignoring.\n"; 991 error "attach argument '$type' not supported, ignoring.\n";
887 } 992 }
888 } 993 }
889} 994}
890 995
891sub _object_attach { 996sub _object_attach {
… …
901 _attach $registry, $klass, @attach; 1006 _attach $registry, $klass, @attach;
902 } 1007 }
903 1008
904 $obj->{$name} = \%arg; 1009 $obj->{$name} = \%arg;
905 } else { 1010 } else {
906 warn "object uses attachment '$name' which is not available, postponing.\n"; 1011 info "object uses attachment '$name' which is not available, postponing.\n";
907 } 1012 }
908 1013
909 $obj->{_attachment}{$name} = undef; 1014 $obj->{_attachment}{$name} = undef;
910} 1015}
911 1016
… …
970 1075
971 for (@$callbacks) { 1076 for (@$callbacks) {
972 eval { &{$_->[1]} }; 1077 eval { &{$_->[1]} };
973 1078
974 if ($@) { 1079 if ($@) {
975 warn "$@";
976 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1080 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
977 override; 1081 override;
978 } 1082 }
979 1083
980 return 1 if $override; 1084 return 1 if $override;
981 } 1085 }
… …
1044 1148
1045sub reattach { 1149sub reattach {
1046 # basically do the same as instantiate, without calling instantiate 1150 # basically do the same as instantiate, without calling instantiate
1047 my ($obj) = @_; 1151 my ($obj) = @_;
1048 1152
1153 # no longer needed after getting rid of delete_package?
1049 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
1050 1155
1051 my $registry = $obj->registry; 1156 my $registry = $obj->registry;
1052 1157
1053 @$registry = (); 1158 @$registry = ();
1054 1159
… …
1059 for (@$attach) { 1164 for (@$attach) {
1060 my ($klass, @attach) = @$_; 1165 my ($klass, @attach) = @$_;
1061 _attach $registry, $klass, @attach; 1166 _attach $registry, $klass, @attach;
1062 } 1167 }
1063 } else { 1168 } else {
1064 warn "object uses attachment '$name' that is not available, postponing.\n"; 1169 info "object uses attachment '$name' that is not available, postponing.\n";
1065 } 1170 }
1066 } 1171 }
1067} 1172}
1068 1173
1069cf::attachable->attach ( 1174cf::attachable->attach (
… …
1096 my ($filename, $rdata, $objs) = @_; 1201 my ($filename, $rdata, $objs) = @_;
1097 1202
1098 sync_job { 1203 sync_job {
1099 if (length $$rdata) { 1204 if (length $$rdata) {
1100 utf8::decode (my $decname = $filename); 1205 utf8::decode (my $decname = $filename);
1101 warn sprintf "saving %s (%d,%d)\n", 1206 trace sprintf "saving %s (%d,%d)\n",
1102 $decname, length $$rdata, scalar @$objs; 1207 $decname, length $$rdata, scalar @$objs
1208 if $VERBOSE_IO;
1103 1209
1104 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1210 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1105 chmod SAVE_MODE, $fh; 1211 aio_chmod $fh, SAVE_MODE;
1106 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1212 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1107 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 }
1108 close $fh; 1217 aio_close $fh;
1109 1218
1110 if (@$objs) { 1219 if (@$objs) {
1111 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) {
1112 chmod SAVE_MODE, $fh; 1221 aio_chmod $fh, SAVE_MODE;
1113 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs }; 1222 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1114 aio_write $fh, 0, (length $data), $data, 0; 1223 aio_write $fh, 0, (length $data), $data, 0;
1115 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 }
1116 close $fh; 1228 aio_close $fh;
1117 aio_rename "$filename.pst~", "$filename.pst"; 1229 aio_rename "$filename.pst~", "$filename.pst";
1118 } 1230 }
1119 } else { 1231 } else {
1120 aio_unlink "$filename.pst"; 1232 aio_unlink "$filename.pst";
1121 } 1233 }
1122 1234
1123 aio_rename "$filename~", $filename; 1235 aio_rename "$filename~", $filename;
1236
1237 $filename =~ s%/[^/]+$%%;
1238 aio_pathsync $filename if $cf::USE_FSYNC;
1124 } else { 1239 } else {
1125 warn "FATAL: $filename~: $!\n"; 1240 error "unable to save objects: $filename~: $!\n";
1126 } 1241 }
1127 } else { 1242 } else {
1128 aio_unlink $filename; 1243 aio_unlink $filename;
1129 aio_unlink "$filename.pst"; 1244 aio_unlink "$filename.pst";
1130 } 1245 }
… …
1154 my $st = eval { Coro::Storable::thaw $av }; 1269 my $st = eval { Coro::Storable::thaw $av };
1155 $av = $st->{objs}; 1270 $av = $st->{objs};
1156 } 1271 }
1157 1272
1158 utf8::decode (my $decname = $filename); 1273 utf8::decode (my $decname = $filename);
1159 warn sprintf "loading %s (%d,%d)\n", 1274 trace sprintf "loading %s (%d,%d)\n",
1160 $decname, length $data, scalar @{$av || []}; 1275 $decname, length $data, scalar @{$av || []}
1276 if $VERBOSE_IO;
1161 1277
1162 ($data, $av) 1278 ($data, $av)
1163} 1279}
1164 1280
1165=head2 COMMAND CALLBACKS 1281=head2 COMMAND CALLBACKS
… …
1221 my ($name, $cb) = @_; 1337 my ($name, $cb) = @_;
1222 1338
1223 $EXTICMD{$name} = $cb; 1339 $EXTICMD{$name} = $cb;
1224} 1340}
1225 1341
1342use File::Glob ();
1343
1226cf::player->attach ( 1344cf::player->attach (
1227 on_command => sub { 1345 on_unknown_command => sub {
1228 my ($pl, $name, $params) = @_; 1346 my ($pl, $name, $params) = @_;
1229 1347
1230 my $cb = $COMMAND{$name} 1348 my $cb = $COMMAND{$name}
1231 or return; 1349 or return;
1232 1350
… …
1255 1373
1256 $pl->ext_reply ($reply, @reply) 1374 $pl->ext_reply ($reply, @reply)
1257 if $reply; 1375 if $reply;
1258 1376
1259 } else { 1377 } else {
1260 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1378 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1261 } 1379 }
1262 1380
1263 cf::override; 1381 cf::override;
1264 }, 1382 },
1265); 1383);
1266 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
1267sub load_extensions { 1398sub load_extensions {
1399 info "loading extensions...";
1400
1268 cf::sync_job { 1401 cf::sync_job {
1269 my %todo; 1402 my %todo;
1270 1403
1271 for my $path (<$LIBDIR/*.ext>) { 1404 for my $path (<$LIBDIR/*.ext>) {
1272 next unless -r $path; 1405 next unless -r $path;
… …
1290 1423
1291 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1424 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1292 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1425 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1293 1426
1294 $ext{source} = 1427 $ext{source} =
1295 "package $pkg; use strict; use utf8;\n" 1428 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1296 . "#line 1 \"$path\"\n{\n" 1429 . "#line 1 \"$path\"\n{\n"
1297 . $source 1430 . $source
1298 . "\n};\n1"; 1431 . "\n};\n1";
1299 1432
1300 $todo{$base} = \%ext; 1433 $todo{$base} = \%ext;
1301 } 1434 }
1302 1435
1436 my $pass = 0;
1303 my %done; 1437 my %done;
1304 while (%todo) { 1438 while (%todo) {
1305 my $progress; 1439 my $progress;
1306 1440
1441 ++$pass;
1442
1443 ext:
1307 while (my ($k, $v) = each %todo) { 1444 while (my ($k, $v) = each %todo) {
1308 for (split /,\s*/, $v->{meta}{depends}) { 1445 for (split /,\s*/, $v->{meta}{depends}) {
1309 goto skip 1446 next ext
1310 unless exists $done{$_}; 1447 unless exists $done{$_};
1311 } 1448 }
1312 1449
1313 warn "... loading '$k' into '$v->{pkg}'\n"; 1450 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1314 1451
1315 unless (eval $v->{source}) { 1452 my $active = eval $v->{source};
1453
1454 if (length $@) {
1316 my $msg = $@ ? "$v->{path}: $@\n" 1455 error "$v->{path}: $@\n";
1317 : "$v->{base}: extension inactive.\n";
1318 1456
1319 if (exists $v->{meta}{mandatory}) {
1320 warn $msg;
1321 cf::cleanup "mandatory extension failed to load, exiting."; 1457 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1322 } 1458 if exists $v->{meta}{mandatory};
1323 1459
1324 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;
1325 } 1469 }
1326
1327 $done{$k} = delete $todo{$k};
1328 push @EXTS, $v->{pkg};
1329 $progress = 1;
1330 } 1470 }
1331 1471
1332 skip: 1472 unless ($progress) {
1333 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1473 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1334 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 }
1335 } 1480 }
1336 }; 1481 };
1337} 1482}
1338 1483
1339############################################################################# 1484#############################################################################
1340 1485
1341=back 1486=back
1342 1487
1343=head2 CORE EXTENSIONS 1488=head2 CORE EXTENSIONS
1344 1489
1345Functions and methods that extend core crossfire objects. 1490Functions and methods that extend core deliantra objects.
1346 1491
1347=cut 1492=cut
1348 1493
1349package cf::player; 1494package cf::player;
1350 1495
… …
1393 1538
1394sub exists($) { 1539sub exists($) {
1395 my ($login) = @_; 1540 my ($login) = @_;
1396 1541
1397 $cf::PLAYER{$login} 1542 $cf::PLAYER{$login}
1398 or cf::sync_job { !aio_stat path $login } 1543 or !aio_stat path $login
1399} 1544}
1400 1545
1401sub find($) { 1546sub find($) {
1402 return $cf::PLAYER{$_[0]} || do { 1547 return $cf::PLAYER{$_[0]} || do {
1403 my $login = $_[0]; 1548 my $login = $_[0];
… …
1415 my $f = new_from_file cf::object::thawer path $login 1560 my $f = new_from_file cf::object::thawer path $login
1416 or return; 1561 or return;
1417 1562
1418 my $pl = cf::player::load_pl $f 1563 my $pl = cf::player::load_pl $f
1419 or return; 1564 or return;
1565
1420 local $cf::PLAYER_LOADING{$login} = $pl; 1566 local $cf::PLAYER_LOADING{$login} = $pl;
1421 $f->resolve_delayed_derefs; 1567 $f->resolve_delayed_derefs;
1422 $cf::PLAYER{$login} = $pl 1568 $cf::PLAYER{$login} = $pl
1423 } 1569 }
1424 } 1570 }
1425} 1571}
1426 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
1427sub save($) { 1586sub save($) {
1428 my ($pl) = @_; 1587 my ($pl) = @_;
1429 1588
1430 return if $pl->{deny_save}; 1589 return if $pl->{deny_save};
1431 1590
… …
1434 1593
1435 return if $pl->{deny_save}; 1594 return if $pl->{deny_save};
1436 1595
1437 aio_mkdir playerdir $pl, 0770; 1596 aio_mkdir playerdir $pl, 0770;
1438 $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];
1439 1603
1440 $pl->save_pl ($path); 1604 $pl->save_pl ($path);
1441 cf::cede_to_tick; 1605 cf::cede_to_tick;
1442} 1606}
1443 1607
… …
1475 my ($pl) = @_; 1639 my ($pl) = @_;
1476 1640
1477 my $name = $pl->ob->name; 1641 my $name = $pl->ob->name;
1478 1642
1479 $pl->{deny_save} = 1; 1643 $pl->{deny_save} = 1;
1480 $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
1481 1645
1482 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1646 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1483 $pl->deactivate; 1647 $pl->deactivate;
1648 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1484 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1649 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1485 $pl->ns->destroy if $pl->ns; 1650 $pl->ns->destroy if $pl->ns;
1486 1651
1487 my $path = playerdir $pl; 1652 my $path = playerdir $pl;
1488 my $temp = "$path~$cf::RUNTIME~deleting~"; 1653 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1527 1692
1528 for my $login (@$dirs) { 1693 for my $login (@$dirs) {
1529 my $path = path $login; 1694 my $path = path $login;
1530 1695
1531 # a .pst is a dead give-away for a valid player 1696 # a .pst is a dead give-away for a valid player
1532 unless (-e "$path.pst") { 1697 # if no pst file found, open and chekc for blocked users
1698 if (aio_stat "$path.pst") {
1533 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next; 1699 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1534 aio_read $fh, 0, 512, my $buf, 0 or next; 1700 aio_read $fh, 0, 512, my $buf, 0 or next;
1535 $buf !~ /^password -------------$/m or next; # official not-valid tag 1701 $buf !~ /^password -------------$/m or next; # official not-valid tag
1536 } 1702 }
1537 1703
… …
1541 1707
1542 \@logins 1708 \@logins
1543} 1709}
1544 1710
1545=item $player->maps 1711=item $player->maps
1712
1713=item cf::player::maps $login
1546 1714
1547Returns an arrayref of map paths that are private for this 1715Returns an arrayref of map paths that are private for this
1548player. May block. 1716player. May block.
1549 1717
1550=cut 1718=cut
… …
1568 } 1736 }
1569 1737
1570 \@paths 1738 \@paths
1571} 1739}
1572 1740
1573=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1741=item $protocol_xml = $player->expand_cfpod ($cfpod)
1574 1742
1575Expand crossfire pod fragments into protocol xml. 1743Expand deliantra pod fragments into protocol xml.
1576
1577=cut
1578
1579use re 'eval';
1580
1581my $group;
1582my $interior; $interior = qr{
1583 # match a pod interior sequence sans C<< >>
1584 (?:
1585 \ (.*?)\ (?{ $group = $^N })
1586 | < (??{$interior}) >
1587 )
1588}x;
1589
1590sub expand_cfpod {
1591 my ($self, $pod) = @_;
1592
1593 my $xml;
1594
1595 while () {
1596 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1597 $group = $1;
1598
1599 $group =~ s/&/&amp;/g;
1600 $group =~ s/</&lt;/g;
1601
1602 $xml .= $group;
1603 } elsif ($pod =~ m%\G
1604 ([BCGHITU])
1605 <
1606 (?:
1607 ([^<>]*) (?{ $group = $^N })
1608 | < $interior >
1609 )
1610 >
1611 %gcsx
1612 ) {
1613 my ($code, $data) = ($1, $group);
1614
1615 if ($code eq "B") {
1616 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1617 } elsif ($code eq "I") {
1618 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1619 } elsif ($code eq "U") {
1620 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1621 } elsif ($code eq "C") {
1622 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1623 } elsif ($code eq "T") {
1624 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1625 } elsif ($code eq "G") {
1626 my ($male, $female) = split /\|/, $data;
1627 $data = $self->gender ? $female : $male;
1628 $xml .= expand_cfpod ($self, $data);
1629 } elsif ($code eq "H") {
1630 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1631 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1632 "")
1633 [$self->{hintmode}];
1634 } else {
1635 $xml .= "error processing '$code($data)' directive";
1636 }
1637 } else {
1638 if ($pod =~ /\G(.+)/) {
1639 warn "parse error while expanding $pod (at $1)";
1640 }
1641 last;
1642 }
1643 }
1644
1645 for ($xml) {
1646 # create single paragraphs (very hackish)
1647 s/(?<=\S)\n(?=\w)/ /g;
1648
1649 # compress some whitespace
1650 s/\s+\n/\n/g; # ws line-ends
1651 s/\n\n+/\n/g; # double lines
1652 s/^\n+//; # beginning lines
1653 s/\n+$//; # ending lines
1654 }
1655
1656 $xml
1657}
1658
1659no re 'eval';
1660
1661sub hintmode {
1662 $_[0]{hintmode} = $_[1] if @_ > 1;
1663 $_[0]{hintmode}
1664}
1665 1744
1666=item $player->ext_reply ($msgid, @msg) 1745=item $player->ext_reply ($msgid, @msg)
1667 1746
1668Sends an ext reply to the player. 1747Sends an ext reply to the player.
1669 1748
… …
1701 1780
1702=cut 1781=cut
1703 1782
1704sub find_by_path($) { 1783sub find_by_path($) {
1705 my ($path) = @_; 1784 my ($path) = @_;
1785
1786 $path =~ s/^~[^\/]*//; # skip ~login
1706 1787
1707 my ($match, $specificity); 1788 my ($match, $specificity);
1708 1789
1709 for my $region (list) { 1790 for my $region (list) {
1710 if ($region->{match} && $path =~ $region->{match}) { 1791 if ($region->{match} && $path =~ $region->{match}) {
… …
1736our $MAX_RESET = 3600; 1817our $MAX_RESET = 3600;
1737our $DEFAULT_RESET = 3000; 1818our $DEFAULT_RESET = 3000;
1738 1819
1739sub generate_random_map { 1820sub generate_random_map {
1740 my ($self, $rmp) = @_; 1821 my ($self, $rmp) = @_;
1822
1823 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1824
1741 # mit "rum" bekleckern, nicht 1825 # mit "rum" bekleckern, nicht
1742 $self->_create_random_map ( 1826 $self->_create_random_map (
1743 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1827 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1744 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1828 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1745 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1829 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1746 $rmp->{exit_on_final_map}, 1830 $rmp->{exit_on_final_map},
1747 $rmp->{xsize}, $rmp->{ysize}, 1831 $rmp->{xsize}, $rmp->{ysize},
1748 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1832 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1749 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1833 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1771 1855
1772 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1856 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1773} 1857}
1774 1858
1775# also paths starting with '/' 1859# also paths starting with '/'
1776$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1860$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1777 1861
1778sub thawer_merge { 1862sub thawer_merge {
1779 my ($self, $merge) = @_; 1863 my ($self, $merge) = @_;
1780 1864
1781 # we have to keep some variables in memory intact 1865 # we have to keep some variables in memory intact
… …
1867 1951
1868# the temporary/swap location 1952# the temporary/swap location
1869sub save_path { 1953sub save_path {
1870 my ($self) = @_; 1954 my ($self) = @_;
1871 1955
1872 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1956 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1873 "$TMPDIR/$path.map" 1957 "$TMPDIR/$path.map"
1874} 1958}
1875 1959
1876# the unique path, undef == no special unique path 1960# the unique path, undef == no special unique path
1877sub uniq_path { 1961sub uniq_path {
1878 my ($self) = @_; 1962 my ($self) = @_;
1879 1963
1880 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1964 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1881 "$UNIQUEDIR/$path" 1965 "$UNIQUEDIR/$path"
1882}
1883
1884# and all this just because we cannot iterate over
1885# all maps in C++...
1886sub change_all_map_light {
1887 my ($change) = @_;
1888
1889 $_->change_map_light ($change)
1890 for grep $_->outdoor, values %cf::MAP;
1891} 1966}
1892 1967
1893sub decay_objects { 1968sub decay_objects {
1894 my ($self) = @_; 1969 my ($self) = @_;
1895 1970
… …
1979sub find { 2054sub find {
1980 my ($path, $origin) = @_; 2055 my ($path, $origin) = @_;
1981 2056
1982 $path = normalise $path, $origin && $origin->path; 2057 $path = normalise $path, $origin && $origin->path;
1983 2058
1984 cf::lock_wait "map_data:$path";#d#remove 2059 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1985 cf::lock_wait "map_find:$path"; 2060 my $guard2 = cf::lock_acquire "map_find:$path";
1986 2061
1987 $cf::MAP{$path} || do { 2062 $cf::MAP{$path} || do {
1988 my $guard1 = cf::lock_acquire "map_find:$path";
1989 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1990
1991 my $map = new_from_path cf::map $path 2063 my $map = new_from_path cf::map $path
1992 or return; 2064 or return;
1993 2065
1994 $map->{last_save} = $cf::RUNTIME; 2066 $map->{last_save} = $cf::RUNTIME;
1995 2067
… …
1997 or return; 2069 or return;
1998 2070
1999 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2071 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2000 # doing this can freeze the server in a sync job, obviously 2072 # doing this can freeze the server in a sync job, obviously
2001 #$cf::WAIT_FOR_TICK->wait; 2073 #$cf::WAIT_FOR_TICK->wait;
2074 undef $guard2;
2002 undef $guard1; 2075 undef $guard1;
2003 undef $guard2;
2004 $map->reset; 2076 $map->reset;
2005 return find $path; 2077 return find $path;
2006 } 2078 }
2007 2079
2008 $cf::MAP{$path} = $map 2080 $cf::MAP{$path} = $map
2009 } 2081 }
2010} 2082}
2011 2083
2012sub pre_load { } 2084sub pre_load { }
2013sub post_load { } 2085#sub post_load { } # XS
2014 2086
2015sub load { 2087sub load {
2016 my ($self) = @_; 2088 my ($self) = @_;
2017 2089
2018 local $self->{deny_reset} = 1; # loading can take a long time 2090 local $self->{deny_reset} = 1; # loading can take a long time
… …
2035 my $f = new_from_file cf::object::thawer $self->{load_path}; 2107 my $f = new_from_file cf::object::thawer $self->{load_path};
2036 $f->skip_block; 2108 $f->skip_block;
2037 $self->_load_objects ($f) 2109 $self->_load_objects ($f)
2038 or return; 2110 or return;
2039 2111
2040 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2112 $self->post_load_original
2041 if delete $self->{load_original}; 2113 if delete $self->{load_original};
2042 2114
2043 if (my $uniq = $self->uniq_path) { 2115 if (my $uniq = $self->uniq_path) {
2044 utf8::encode $uniq; 2116 utf8::encode $uniq;
2045 unless (aio_stat $uniq) { 2117 unless (aio_stat $uniq) {
… …
2063 unless ($self->{deny_activate}) { 2135 unless ($self->{deny_activate}) {
2064 $self->decay_objects; 2136 $self->decay_objects;
2065 $self->fix_auto_apply; 2137 $self->fix_auto_apply;
2066 $self->update_buttons; 2138 $self->update_buttons;
2067 cf::cede_to_tick; 2139 cf::cede_to_tick;
2068 $self->set_darkness_map;
2069 cf::cede_to_tick;
2070 $self->activate; 2140 $self->activate;
2071 } 2141 }
2072 2142
2073 $self->{last_save} = $cf::RUNTIME; 2143 $self->{last_save} = $cf::RUNTIME;
2074 $self->last_access ($cf::RUNTIME); 2144 $self->last_access ($cf::RUNTIME);
2075 2145
2076 $self->in_memory (cf::MAP_IN_MEMORY); 2146 $self->in_memory (cf::MAP_ACTIVE);
2077 } 2147 }
2078 2148
2079 $self->post_load; 2149 $self->post_load;
2080} 2150}
2081 2151
2152# customize the map for a given player, i.e.
2153# return the _real_ map. used by e.g. per-player
2154# maps to change the path to ~playername/mappath
2082sub customise_for { 2155sub customise_for {
2083 my ($self, $ob) = @_; 2156 my ($self, $ob) = @_;
2084 2157
2085 return find "~" . $ob->name . "/" . $self->{path} 2158 return find "~" . $ob->name . "/" . $self->{path}
2086 if $self->per_player; 2159 if $self->per_player;
… …
2102 or next; 2175 or next;
2103 $neigh = find $neigh, $map 2176 $neigh = find $neigh, $map
2104 or next; 2177 or next;
2105 $neigh->load; 2178 $neigh->load;
2106 2179
2180 # now find the diagonal neighbours
2107 push @neigh, 2181 push @neigh,
2108 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2182 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2109 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2183 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2110 } 2184 }
2111 2185
… …
2118} 2192}
2119 2193
2120sub find_sync { 2194sub find_sync {
2121 my ($path, $origin) = @_; 2195 my ($path, $origin) = @_;
2122 2196
2123 cf::sync_job { find $path, $origin } 2197 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2198 if $Coro::current == $Coro::main;
2199
2200 find $path, $origin
2124} 2201}
2125 2202
2126sub do_load_sync { 2203sub do_load_sync {
2127 my ($map) = @_; 2204 my ($map) = @_;
2128 2205
2129 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2206 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2130 if $Coro::current == $Coro::main; 2207 if $Coro::current == $Coro::main;
2131 2208
2132 cf::sync_job { $map->load }; 2209 $map->load;
2133} 2210}
2134 2211
2135our %MAP_PREFETCH; 2212our %MAP_PREFETCH;
2136our $MAP_PREFETCHER = undef; 2213our $MAP_PREFETCHER = undef;
2137 2214
… …
2139 my ($path, $origin, $load) = @_; 2216 my ($path, $origin, $load) = @_;
2140 2217
2141 $path = normalise $path, $origin && $origin->{path}; 2218 $path = normalise $path, $origin && $origin->{path};
2142 2219
2143 if (my $map = $cf::MAP{$path}) { 2220 if (my $map = $cf::MAP{$path}) {
2144 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2221 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2145 } 2222 }
2146 2223
2147 $MAP_PREFETCH{$path} |= $load; 2224 $MAP_PREFETCH{$path} |= $load;
2148 2225
2149 $MAP_PREFETCHER ||= cf::async { 2226 $MAP_PREFETCHER ||= cf::async {
… …
2163 $MAP_PREFETCHER->prio (6); 2240 $MAP_PREFETCHER->prio (6);
2164 2241
2165 () 2242 ()
2166} 2243}
2167 2244
2245# common code, used by both ->save and ->swapout
2168sub save { 2246sub _save {
2169 my ($self) = @_; 2247 my ($self) = @_;
2170
2171 my $lock = cf::lock_acquire "map_data:$self->{path}";
2172 2248
2173 $self->{last_save} = $cf::RUNTIME; 2249 $self->{last_save} = $cf::RUNTIME;
2174 2250
2175 return unless $self->dirty; 2251 return unless $self->dirty;
2176 2252
… …
2185 2261
2186 cf::async { 2262 cf::async {
2187 $Coro::current->{desc} = "map player save"; 2263 $Coro::current->{desc} = "map player save";
2188 $_->contr->save for $self->players; 2264 $_->contr->save for $self->players;
2189 }; 2265 };
2266
2267 cf::get_slot 0.02;
2190 2268
2191 if ($uniq) { 2269 if ($uniq) {
2192 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2270 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2193 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2271 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2194 } else { 2272 } else {
2195 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2273 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2196 } 2274 }
2197} 2275}
2198 2276
2277sub save {
2278 my ($self) = @_;
2279
2280 my $lock = cf::lock_acquire "map_data:$self->{path}";
2281
2282 $self->_save;
2283}
2284
2199sub swap_out { 2285sub swap_out {
2200 my ($self) = @_; 2286 my ($self) = @_;
2201 2287
2202 # save first because save cedes
2203 $self->save;
2204
2205 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2288 my $lock = cf::lock_acquire "map_data:$self->{path}";
2206 2289
2290 return if $self->in_memory != cf::MAP_ACTIVE;
2291 return if $self->{deny_save};
2207 return if $self->players; 2292 return if $self->players;
2208 return if $self->in_memory != cf::MAP_IN_MEMORY;
2209 return if $self->{deny_save};
2210 2293
2294 # first deactivate the map and "unlink" it from the core
2295 $self->deactivate;
2296 $_->clear_links_to ($self) for values %cf::MAP;
2211 $self->in_memory (cf::MAP_SWAPPED); 2297 $self->in_memory (cf::MAP_SWAPPED);
2298
2299 # then atomically save
2300 $self->_save;
2301
2302 # then free the map
2303 $self->clear;
2304}
2305
2306sub reset_at {
2307 my ($self) = @_;
2308
2309 # TODO: safety, remove and allow resettable per-player maps
2310 return 1e99 if $self->{deny_reset};
2311
2312 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2313 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2314
2315 $time + $to
2316}
2317
2318sub should_reset {
2319 my ($self) = @_;
2320
2321 $self->reset_at <= $cf::RUNTIME
2322}
2323
2324sub reset {
2325 my ($self) = @_;
2326
2327 my $lock = cf::lock_acquire "map_data:$self->{path}";
2328
2329 return if $self->players;
2330
2331 cf::trace "resetting map ", $self->path, "\n";
2332
2333 $self->in_memory (cf::MAP_SWAPPED);
2334
2335 # need to save uniques path
2336 unless ($self->{deny_save}) {
2337 my $uniq = $self->uniq_path; utf8::encode $uniq;
2338
2339 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2340 if $uniq;
2341 }
2342
2343 delete $cf::MAP{$self->path};
2212 2344
2213 $self->deactivate; 2345 $self->deactivate;
2214 $_->clear_links_to ($self) for values %cf::MAP; 2346 $_->clear_links_to ($self) for values %cf::MAP;
2215 $self->clear; 2347 $self->clear;
2216}
2217
2218sub reset_at {
2219 my ($self) = @_;
2220
2221 # TODO: safety, remove and allow resettable per-player maps
2222 return 1e99 if $self->{deny_reset};
2223
2224 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2225 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2226
2227 $time + $to
2228}
2229
2230sub should_reset {
2231 my ($self) = @_;
2232
2233 $self->reset_at <= $cf::RUNTIME
2234}
2235
2236sub reset {
2237 my ($self) = @_;
2238
2239 my $lock = cf::lock_acquire "map_data:$self->{path}";
2240
2241 return if $self->players;
2242
2243 warn "resetting map ", $self->path;
2244
2245 $self->in_memory (cf::MAP_SWAPPED);
2246
2247 # need to save uniques path
2248 unless ($self->{deny_save}) {
2249 my $uniq = $self->uniq_path; utf8::encode $uniq;
2250
2251 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2252 if $uniq;
2253 }
2254
2255 delete $cf::MAP{$self->path};
2256
2257 $self->deactivate;
2258 $_->clear_links_to ($self) for values %cf::MAP;
2259 $self->clear;
2260 2348
2261 $self->unlink_save; 2349 $self->unlink_save;
2262 $self->destroy; 2350 $self->destroy;
2263} 2351}
2264 2352
… …
2272 2360
2273 delete $cf::MAP{$self->path}; 2361 delete $cf::MAP{$self->path};
2274 2362
2275 $self->unlink_save; 2363 $self->unlink_save;
2276 2364
2277 bless $self, "cf::map"; 2365 bless $self, "cf::map::wrap";
2278 delete $self->{deny_reset}; 2366 delete $self->{deny_reset};
2279 $self->{deny_save} = 1; 2367 $self->{deny_save} = 1;
2280 $self->reset_timeout (1); 2368 $self->reset_timeout (1);
2281 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2369 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2282 2370
… …
2331 2419
2332sub unique_maps() { 2420sub unique_maps() {
2333 [ 2421 [
2334 map { 2422 map {
2335 utf8::decode $_; 2423 utf8::decode $_;
2336 /\.map$/ 2424 s/\.map$//; # TODO future compatibility hack
2425 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2426 ? ()
2337 ? normalise $_ 2427 : normalise $_
2338 : ()
2339 } @{ aio_readdir $UNIQUEDIR or [] } 2428 } @{ aio_readdir $UNIQUEDIR or [] }
2340 ] 2429 ]
2341} 2430}
2342 2431
2343package cf; 2432=item cf::map::static_maps
2433
2434Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2435file in the shared directory excluding F</styles> and F</editor>). May
2436block.
2437
2438=cut
2439
2440sub static_maps() {
2441 my @dirs = "";
2442 my @maps;
2443
2444 while (@dirs) {
2445 my $dir = shift @dirs;
2446
2447 next if $dir eq "/styles" || $dir eq "/editor";
2448
2449 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2450 or return;
2451
2452 for (@$files) {
2453 s/\.map$// or next;
2454 utf8::decode $_;
2455 push @maps, "$dir/$_";
2456 }
2457
2458 push @dirs, map "$dir/$_", @$dirs;
2459 }
2460
2461 \@maps
2462}
2344 2463
2345=back 2464=back
2346 2465
2347=head3 cf::object 2466=head3 cf::object
2348 2467
… …
2352 2471
2353=over 4 2472=over 4
2354 2473
2355=item $ob->inv_recursive 2474=item $ob->inv_recursive
2356 2475
2357Returns the inventory of the object _and_ their inventories, recursively. 2476Returns the inventory of the object I<and> their inventories, recursively,
2477but I<not> the object itself.
2358 2478
2359=cut 2479=cut
2360 2480
2361sub inv_recursive_; 2481sub inv_recursive_;
2362sub inv_recursive_ { 2482sub inv_recursive_ {
… …
2367 inv_recursive_ inv $_[0] 2487 inv_recursive_ inv $_[0]
2368} 2488}
2369 2489
2370=item $ref = $ob->ref 2490=item $ref = $ob->ref
2371 2491
2372creates and returns a persistent reference to an objetc that can be stored as a string. 2492Creates and returns a persistent reference to an object that can be stored as a string.
2373 2493
2374=item $ob = cf::object::deref ($refstring) 2494=item $ob = cf::object::deref ($refstring)
2375 2495
2376returns the objetc referenced by refstring. may return undef when it cnanot find the object, 2496returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2377even if the object actually exists. May block. 2497even if the object actually exists. May block.
… …
2409can be C<undef>. Does the right thing when the player is currently in a 2529can be C<undef>. Does the right thing when the player is currently in a
2410dialogue with the given NPC character. 2530dialogue with the given NPC character.
2411 2531
2412=cut 2532=cut
2413 2533
2534our $SAY_CHANNEL = {
2535 id => "say",
2536 title => "Map",
2537 reply => "say ",
2538 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2539};
2540
2541our $CHAT_CHANNEL = {
2542 id => "chat",
2543 title => "Chat",
2544 reply => "chat ",
2545 tooltip => "Player chat and shouts, global to the server.",
2546};
2547
2414# rough implementation of a future "reply" method that works 2548# rough implementation of a future "reply" method that works
2415# with dialog boxes. 2549# with dialog boxes.
2416#TODO: the first argument must go, split into a $npc->reply_to ( method 2550#TODO: the first argument must go, split into a $npc->reply_to ( method
2417sub cf::object::player::reply($$$;$) { 2551sub cf::object::player::reply($$$;$) {
2418 my ($self, $npc, $msg, $flags) = @_; 2552 my ($self, $npc, $msg, $flags) = @_;
… …
2429 my $dialog = $pl->{npc_dialog}; 2563 my $dialog = $pl->{npc_dialog};
2430 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2564 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2431 2565
2432 } else { 2566 } else {
2433 $msg = $npc->name . " says: $msg" if $npc; 2567 $msg = $npc->name . " says: $msg" if $npc;
2434 $self->message ($msg, $flags); 2568 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2435 } 2569 }
2436 } 2570 }
2437} 2571}
2438 2572
2439=item $object->send_msg ($channel, $msg, $color, [extra...]) 2573=item $object->send_msg ($channel, $msg, $color, [extra...])
… …
2464 2598
2465=item $player_object->enter_link 2599=item $player_object->enter_link
2466 2600
2467Freezes the player and moves him/her to a special map (C<{link}>). 2601Freezes the player and moves him/her to a special map (C<{link}>).
2468 2602
2469The player should be reasonably safe there for short amounts of time. You 2603The player should be reasonably safe there for short amounts of time (e.g.
2470I<MUST> call C<leave_link> as soon as possible, though. 2604for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2605though, as the player cannot control the character while it is on the link
2606map.
2471 2607
2472Will never block. 2608Will never block.
2473 2609
2474=item $player_object->leave_link ($map, $x, $y) 2610=item $player_object->leave_link ($map, $x, $y)
2475 2611
… …
2495sub cf::object::player::enter_link { 2631sub cf::object::player::enter_link {
2496 my ($self) = @_; 2632 my ($self) = @_;
2497 2633
2498 $self->deactivate_recursive; 2634 $self->deactivate_recursive;
2499 2635
2636 ++$self->{_link_recursion};
2637
2500 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2638 return if UNIVERSAL::isa $self->map, "ext::map_link";
2501 2639
2502 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2640 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2503 if $self->map && $self->map->{path} ne "{link}"; 2641 if $self->map && $self->map->{path} ne "{link}";
2504 2642
2505 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2643 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2506} 2644}
2507 2645
2508sub cf::object::player::leave_link { 2646sub cf::object::player::leave_link {
2509 my ($self, $map, $x, $y) = @_; 2647 my ($self, $map, $x, $y) = @_;
2510 2648
… …
2527 ($x, $y) = (-1, -1) 2665 ($x, $y) = (-1, -1)
2528 unless (defined $x) && (defined $y); 2666 unless (defined $x) && (defined $y);
2529 2667
2530 # use -1 or undef as default coordinates, not 0, 0 2668 # use -1 or undef as default coordinates, not 0, 0
2531 ($x, $y) = ($map->enter_x, $map->enter_y) 2669 ($x, $y) = ($map->enter_x, $map->enter_y)
2532 if $x <=0 && $y <= 0; 2670 if $x <= 0 && $y <= 0;
2533 2671
2534 $map->load; 2672 $map->load;
2535 $map->load_neighbours; 2673 $map->load_neighbours;
2536 2674
2537 return unless $self->contr->active; 2675 return unless $self->contr->active;
2538 $self->activate_recursive;
2539 2676
2540 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2677 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2541 $self->enter_map ($map, $x, $y); 2678 if ($self->enter_map ($map, $x, $y)) {
2542} 2679 # entering was successful
2680 delete $self->{_link_recursion};
2681 # only activate afterwards, to support waiting in hooks
2682 $self->activate_recursive;
2683 }
2543 2684
2685}
2686
2544=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2687=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2545 2688
2546Moves the player to the given map-path and coordinates by first freezing 2689Moves the player to the given map-path and coordinates by first freezing
2547her, loading and preparing them map, calling the provided $check callback 2690her, loading and preparing them map, calling the provided $check callback
2548that has to return the map if sucecssful, and then unfreezes the player on 2691that has to return the map if sucecssful, and then unfreezes the player on
2549the new (success) or old (failed) map position. In either case, $done will 2692the new (success) or old (failed) map position. In either case, $done will
2550be called at the end of this process. 2693be called at the end of this process.
2551 2694
2695Note that $check will be called with a potentially non-loaded map, so if
2696it needs a loaded map it has to call C<< ->load >>.
2697
2552=cut 2698=cut
2553 2699
2554our $GOTOGEN; 2700our $GOTOGEN;
2555 2701
2556sub cf::object::player::goto { 2702sub cf::object::player::goto {
2557 my ($self, $path, $x, $y, $check, $done) = @_; 2703 my ($self, $path, $x, $y, $check, $done) = @_;
2704
2705 if ($self->{_link_recursion} >= $MAX_LINKS) {
2706 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2707 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2708 ($path, $x, $y) = @$EMERGENCY_POSITION;
2709 }
2558 2710
2559 # do generation counting so two concurrent goto's will be executed in-order 2711 # do generation counting so two concurrent goto's will be executed in-order
2560 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2712 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2561 2713
2562 $self->enter_link; 2714 $self->enter_link;
… …
2586 my $map = eval { 2738 my $map = eval {
2587 my $map = defined $path ? cf::map::find $path : undef; 2739 my $map = defined $path ? cf::map::find $path : undef;
2588 2740
2589 if ($map) { 2741 if ($map) {
2590 $map = $map->customise_for ($self); 2742 $map = $map->customise_for ($self);
2591 $map = $check->($map) if $check && $map; 2743 $map = $check->($map, $x, $y, $self) if $check && $map;
2592 } else { 2744 } else {
2593 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2745 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2594 } 2746 }
2595 2747
2596 $map 2748 $map
… …
2604 if ($gen == $self->{_goto_generation}) { 2756 if ($gen == $self->{_goto_generation}) {
2605 delete $self->{_goto_generation}; 2757 delete $self->{_goto_generation};
2606 $self->leave_link ($map, $x, $y); 2758 $self->leave_link ($map, $x, $y);
2607 } 2759 }
2608 2760
2609 $done->() if $done; 2761 $done->($self) if $done;
2610 })->prio (1); 2762 })->prio (1);
2611} 2763}
2612 2764
2613=item $player_object->enter_exit ($exit_object) 2765=item $player_object->enter_exit ($exit_object)
2614 2766
… …
2634} 2786}
2635 2787
2636sub prepare_random_map { 2788sub prepare_random_map {
2637 my ($exit) = @_; 2789 my ($exit) = @_;
2638 2790
2639 my $guard = cf::lock_acquire "exit_prepare:$exit";
2640
2641 # all this does is basically replace the /! path by 2791 # all this does is basically replace the /! path by
2642 # a new random map path (?random/...) with a seed 2792 # a new random map path (?random/...) with a seed
2643 # that depends on the exit object 2793 # that depends on the exit object
2644 2794
2645 my $rmp = parse_random_map_params $exit->msg; 2795 my $rmp = parse_random_map_params $exit->msg;
… …
2647 if ($exit->map) { 2797 if ($exit->map) {
2648 $rmp->{region} = $exit->region->name; 2798 $rmp->{region} = $exit->region->name;
2649 $rmp->{origin_map} = $exit->map->path; 2799 $rmp->{origin_map} = $exit->map->path;
2650 $rmp->{origin_x} = $exit->x; 2800 $rmp->{origin_x} = $exit->x;
2651 $rmp->{origin_y} = $exit->y; 2801 $rmp->{origin_y} = $exit->y;
2802
2803 $exit->map->touch;
2652 } 2804 }
2653 2805
2654 $rmp->{random_seed} ||= $exit->random_seed; 2806 $rmp->{random_seed} ||= $exit->random_seed;
2655 2807
2656 my $data = cf::encode_json $rmp; 2808 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2657 my $md5 = Digest::MD5::md5_hex $data; 2809 my $md5 = Digest::MD5::md5_hex $data;
2658 my $meta = "$RANDOMDIR/$md5.meta"; 2810 my $meta = "$RANDOMDIR/$md5.meta";
2659 2811
2660 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2812 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2661 aio_write $fh, 0, (length $data), $data, 0; 2813 aio_write $fh, 0, (length $data), $data, 0;
2662 undef $fh; 2814 undef $fh;
2663 aio_rename "$meta~", $meta; 2815 aio_rename "$meta~", $meta;
2664 2816
2817 my $slaying = "?random/$md5";
2818
2819 if ($exit->valid) {
2665 $exit->slaying ("?random/$md5"); 2820 $exit->slaying ("?random/$md5");
2666 $exit->msg (undef); 2821 $exit->msg (undef);
2822 }
2667 } 2823 }
2668} 2824}
2669 2825
2670sub cf::object::player::enter_exit { 2826sub cf::object::player::enter_exit {
2671 my ($self, $exit) = @_; 2827 my ($self, $exit) = @_;
2672 2828
2673 return unless $self->type == cf::PLAYER; 2829 return unless $self->type == cf::PLAYER;
2674 2830
2675 if ($exit->slaying eq "/!") {
2676 #TODO: this should de-fi-ni-te-ly not be a sync-job
2677 # the problem is that $exit might not survive long enough
2678 # so it needs to be done right now, right here
2679 cf::sync_job { prepare_random_map $exit };
2680 }
2681
2682 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2683 my $hp = $exit->stats->hp;
2684 my $sp = $exit->stats->sp;
2685
2686 $self->enter_link; 2831 $self->enter_link;
2687 2832
2688 # if exit is damned, update players death & WoR home-position
2689 $self->contr->savebed ($slaying, $hp, $sp)
2690 if $exit->flag (FLAG_DAMNED);
2691
2692 (async { 2833 (async {
2693 $Coro::current->{desc} = "enter_exit $slaying $hp $sp"; 2834 $Coro::current->{desc} = "enter_exit";
2694 2835
2695 $self->deactivate_recursive; # just to be sure
2696 unless (eval { 2836 unless (eval {
2837 $self->deactivate_recursive; # just to be sure
2838
2839 # random map handling
2840 {
2841 my $guard = cf::lock_acquire "exit_prepare:$exit";
2842
2843 prepare_random_map $exit
2844 if $exit->slaying eq "/!";
2845 }
2846
2847 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2848 my $x = $exit->stats->hp;
2849 my $y = $exit->stats->sp;
2850
2697 $self->goto ($slaying, $hp, $sp); 2851 $self->goto ($map, $x, $y);
2698 2852
2853 # if exit is damned, update players death & WoR home-position
2854 $self->contr->savebed ($map, $x, $y)
2855 if $exit->flag (cf::FLAG_DAMNED);
2856
2699 1; 2857 1
2700 }) { 2858 }) {
2701 $self->message ("Something went wrong deep within the crossfire server. " 2859 $self->message ("Something went wrong deep within the deliantra server. "
2702 . "I'll try to bring you back to the map you were before. " 2860 . "I'll try to bring you back to the map you were before. "
2703 . "Please report this to the dungeon master!", 2861 . "Please report this to the dungeon master!",
2704 cf::NDI_UNIQUE | cf::NDI_RED); 2862 cf::NDI_UNIQUE | cf::NDI_RED);
2705 2863
2706 warn "ERROR in enter_exit: $@"; 2864 error "ERROR in enter_exit: $@";
2707 $self->leave_link; 2865 $self->leave_link;
2708 } 2866 }
2709 })->prio (1); 2867 })->prio (1);
2710} 2868}
2711 2869
… …
2723sub cf::client::send_drawinfo { 2881sub cf::client::send_drawinfo {
2724 my ($self, $text, $flags) = @_; 2882 my ($self, $text, $flags) = @_;
2725 2883
2726 utf8::encode $text; 2884 utf8::encode $text;
2727 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2885 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2886}
2887
2888=item $client->send_big_packet ($pkt)
2889
2890Like C<send_packet>, but tries to compress large packets, and fragments
2891them as required.
2892
2893=cut
2894
2895our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2896
2897sub cf::client::send_big_packet {
2898 my ($self, $pkt) = @_;
2899
2900 # try lzf for large packets
2901 $pkt = "lzf " . Compress::LZF::compress $pkt
2902 if 1024 <= length $pkt and $self->{can_lzf};
2903
2904 # split very large packets
2905 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2906 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2907 $pkt = "frag";
2908 }
2909
2910 $self->send_packet ($pkt);
2728} 2911}
2729 2912
2730=item $client->send_msg ($channel, $msg, $color, [extra...]) 2913=item $client->send_msg ($channel, $msg, $color, [extra...])
2731 2914
2732Send a drawinfo or msg packet to the client, formatting the msg for the 2915Send a drawinfo or msg packet to the client, formatting the msg for the
… …
2736 2919
2737=cut 2920=cut
2738 2921
2739# non-persistent channels (usually the info channel) 2922# non-persistent channels (usually the info channel)
2740our %CHANNEL = ( 2923our %CHANNEL = (
2924 "c/motd" => {
2925 id => "infobox",
2926 title => "MOTD",
2927 reply => undef,
2928 tooltip => "The message of the day",
2929 },
2741 "c/identify" => { 2930 "c/identify" => {
2742 id => "infobox", 2931 id => "infobox",
2743 title => "Identify", 2932 title => "Identify",
2744 reply => undef, 2933 reply => undef,
2745 tooltip => "Items recently identified", 2934 tooltip => "Items recently identified",
… …
2747 "c/examine" => { 2936 "c/examine" => {
2748 id => "infobox", 2937 id => "infobox",
2749 title => "Examine", 2938 title => "Examine",
2750 reply => undef, 2939 reply => undef,
2751 tooltip => "Signs and other items you examined", 2940 tooltip => "Signs and other items you examined",
2941 },
2942 "c/shopinfo" => {
2943 id => "infobox",
2944 title => "Shop Info",
2945 reply => undef,
2946 tooltip => "What your bargaining skill tells you about the shop",
2752 }, 2947 },
2753 "c/book" => { 2948 "c/book" => {
2754 id => "infobox", 2949 id => "infobox",
2755 title => "Book", 2950 title => "Book",
2756 reply => undef, 2951 reply => undef,
… …
2772 id => "infobox", 2967 id => "infobox",
2773 title => "Body Parts", 2968 title => "Body Parts",
2774 reply => undef, 2969 reply => undef,
2775 tooltip => "Shows which body parts you posess and are available", 2970 tooltip => "Shows which body parts you posess and are available",
2776 }, 2971 },
2972 "c/statistics" => {
2973 id => "infobox",
2974 title => "Statistics",
2975 reply => undef,
2976 tooltip => "Shows your primary statistics",
2977 },
2978 "c/skills" => {
2979 id => "infobox",
2980 title => "Skills",
2981 reply => undef,
2982 tooltip => "Shows your experience per skill and item power",
2983 },
2984 "c/shopitems" => {
2985 id => "infobox",
2986 title => "Shop Items",
2987 reply => undef,
2988 tooltip => "Shows the items currently for sale in this shop",
2989 },
2990 "c/resistances" => {
2991 id => "infobox",
2992 title => "Resistances",
2993 reply => undef,
2994 tooltip => "Shows your resistances",
2995 },
2996 "c/pets" => {
2997 id => "infobox",
2998 title => "Pets",
2999 reply => undef,
3000 tooltip => "Shows information abotu your pets/a specific pet",
3001 },
3002 "c/perceiveself" => {
3003 id => "infobox",
3004 title => "Perceive Self",
3005 reply => undef,
3006 tooltip => "You gained detailed knowledge about yourself",
3007 },
2777 "c/uptime" => { 3008 "c/uptime" => {
2778 id => "infobox", 3009 id => "infobox",
2779 title => "Uptime", 3010 title => "Uptime",
2780 reply => undef, 3011 reply => undef,
2781 tooltip => "How long the server has been running since last restart", 3012 tooltip => "How long the server has been running since last restart",
… …
2784 id => "infobox", 3015 id => "infobox",
2785 title => "Map Info", 3016 title => "Map Info",
2786 reply => undef, 3017 reply => undef,
2787 tooltip => "Information related to the maps", 3018 tooltip => "Information related to the maps",
2788 }, 3019 },
3020 "c/party" => {
3021 id => "party",
3022 title => "Party",
3023 reply => "gsay ",
3024 tooltip => "Messages and chat related to your party",
3025 },
3026 "c/death" => {
3027 id => "death",
3028 title => "Death",
3029 reply => undef,
3030 tooltip => "Reason for and more info about your most recent death",
3031 },
3032 "c/say" => $SAY_CHANNEL,
3033 "c/chat" => $CHAT_CHANNEL,
2789); 3034);
2790 3035
2791sub cf::client::send_msg { 3036sub cf::client::send_msg {
2792 my ($self, $channel, $msg, $color, @extra) = @_; 3037 my ($self, $channel, $msg, $color, @extra) = @_;
2793 3038
2794 $msg = $self->pl->expand_cfpod ($msg); 3039 $msg = $self->pl->expand_cfpod ($msg)
3040 unless $color & cf::NDI_VERBATIM;
2795 3041
2796 $color &= cf::NDI_CLIENT_MASK; # just in case... 3042 $color &= cf::NDI_CLIENT_MASK; # just in case...
2797 3043
2798 # check predefined channels, for the benefit of C 3044 # check predefined channels, for the benefit of C
2799 if ($CHANNEL{$channel}) { 3045 if ($CHANNEL{$channel}) {
2800 $channel = $CHANNEL{$channel}; 3046 $channel = $CHANNEL{$channel};
2801 3047
2802 $self->ext_msg (channel_info => $channel) 3048 $self->ext_msg (channel_info => $channel);
2803 if $self->can_msg;
2804
2805 $channel = $channel->{id}; 3049 $channel = $channel->{id};
2806 3050
2807 } elsif (ref $channel) { 3051 } elsif (ref $channel) {
2808 # send meta info to client, if not yet sent 3052 # send meta info to client, if not yet sent
2809 unless (exists $self->{channel}{$channel->{id}}) { 3053 unless (exists $self->{channel}{$channel->{id}}) {
2810 $self->{channel}{$channel->{id}} = $channel; 3054 $self->{channel}{$channel->{id}} = $channel;
2811 $self->ext_msg (channel_info => $channel) 3055 $self->ext_msg (channel_info => $channel);
2812 if $self->can_msg;
2813 } 3056 }
2814 3057
2815 $channel = $channel->{id}; 3058 $channel = $channel->{id};
2816 } 3059 }
2817 3060
2818 return unless @extra || length $msg; 3061 return unless @extra || length $msg;
2819 3062
2820 if ($self->can_msg) {
2821 # default colour, mask it out 3063 # default colour, mask it out
2822 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3064 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2823 if $color & cf::NDI_DEF; 3065 if $color & cf::NDI_DEF;
2824 3066
2825 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3067 my $pkt = "msg "
3068 . $self->{json_coder}->encode (
2826 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3069 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2827 } else { 3070 );
2828 if ($color >= 0) {
2829 # replace some tags by gcfclient-compatible ones
2830 for ($msg) {
2831 1 while
2832 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2833 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2834 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2835 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2836 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2837 }
2838 3071
2839 $color &= cf::NDI_COLOR_MASK; 3072 $self->send_big_packet ($pkt);
2840
2841 utf8::encode $msg;
2842
2843 if (0 && $msg =~ /\[/) {
2844 # COMMAND/INFO
2845 $self->send_packet ("drawextinfo $color 10 8 $msg")
2846 } else {
2847 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2848 $self->send_packet ("drawinfo $color $msg")
2849 }
2850 }
2851 }
2852} 3073}
2853 3074
2854=item $client->ext_msg ($type, @msg) 3075=item $client->ext_msg ($type, @msg)
2855 3076
2856Sends an ext event to the client. 3077Sends an ext event to the client.
… …
2859 3080
2860sub cf::client::ext_msg($$@) { 3081sub cf::client::ext_msg($$@) {
2861 my ($self, $type, @msg) = @_; 3082 my ($self, $type, @msg) = @_;
2862 3083
2863 if ($self->extcmd == 2) { 3084 if ($self->extcmd == 2) {
2864 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3085 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2865 } elsif ($self->extcmd == 1) { # TODO: remove 3086 } elsif ($self->extcmd == 1) { # TODO: remove
2866 push @msg, msgtype => "event_$type"; 3087 push @msg, msgtype => "event_$type";
2867 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3088 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2868 } 3089 }
2869} 3090}
2870 3091
2871=item $client->ext_reply ($msgid, @msg) 3092=item $client->ext_reply ($msgid, @msg)
2872 3093
… …
2876 3097
2877sub cf::client::ext_reply($$@) { 3098sub cf::client::ext_reply($$@) {
2878 my ($self, $id, @msg) = @_; 3099 my ($self, $id, @msg) = @_;
2879 3100
2880 if ($self->extcmd == 2) { 3101 if ($self->extcmd == 2) {
2881 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3102 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2882 } elsif ($self->extcmd == 1) { 3103 } elsif ($self->extcmd == 1) {
2883 #TODO: version 1, remove 3104 #TODO: version 1, remove
2884 unshift @msg, msgtype => "reply", msgid => $id; 3105 unshift @msg, msgtype => "reply", msgid => $id;
2885 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3106 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2886 } 3107 }
2887} 3108}
2888 3109
2889=item $success = $client->query ($flags, "text", \&cb) 3110=item $success = $client->query ($flags, "text", \&cb)
2890 3111
… …
2961 3182
2962 $ns->ext_reply ($reply, @reply) 3183 $ns->ext_reply ($reply, @reply)
2963 if $reply; 3184 if $reply;
2964 3185
2965 } else { 3186 } else {
2966 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3187 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2967 } 3188 }
2968 3189
2969 cf::override; 3190 cf::override;
2970 }, 3191 },
2971); 3192);
… …
2991 3212
2992 $coro 3213 $coro
2993} 3214}
2994 3215
2995cf::client->attach ( 3216cf::client->attach (
2996 on_destroy => sub { 3217 on_client_destroy => sub {
2997 my ($ns) = @_; 3218 my ($ns) = @_;
2998 3219
2999 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3220 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
3000 }, 3221 },
3001); 3222);
… …
3017our $safe_hole = new Safe::Hole; 3238our $safe_hole = new Safe::Hole;
3018 3239
3019$SIG{FPE} = 'IGNORE'; 3240$SIG{FPE} = 'IGNORE';
3020 3241
3021$safe->permit_only (Opcode::opset qw( 3242$safe->permit_only (Opcode::opset qw(
3022 :base_core :base_mem :base_orig :base_math 3243 :base_core :base_mem :base_orig :base_math :base_loop
3023 grepstart grepwhile mapstart mapwhile 3244 grepstart grepwhile mapstart mapwhile
3024 sort time 3245 sort time
3025)); 3246));
3026 3247
3027# here we export the classes and methods available to script code 3248# here we export the classes and methods available to script code
… …
3030 3251
3031The following functions and methods are available within a safe environment: 3252The following functions and methods are available within a safe environment:
3032 3253
3033 cf::object 3254 cf::object
3034 contr pay_amount pay_player map x y force_find force_add destroy 3255 contr pay_amount pay_player map x y force_find force_add destroy
3035 insert remove name archname title slaying race decrease_ob_nr 3256 insert remove name archname title slaying race decrease split
3257 value
3036 3258
3037 cf::object::player 3259 cf::object::player
3038 player 3260 player
3039 3261
3040 cf::player 3262 cf::player
… …
3045 3267
3046=cut 3268=cut
3047 3269
3048for ( 3270for (
3049 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3271 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3050 insert remove inv name archname title slaying race 3272 insert remove inv nrof name archname title slaying race
3051 decrease_ob_nr destroy)], 3273 decrease split destroy change_exp value msg lore send_msg)],
3052 ["cf::object::player" => qw(player)], 3274 ["cf::object::player" => qw(player)],
3053 ["cf::player" => qw(peaceful)], 3275 ["cf::player" => qw(peaceful send_msg)],
3054 ["cf::map" => qw(trigger)], 3276 ["cf::map" => qw(trigger)],
3055) { 3277) {
3056 no strict 'refs'; 3278 no strict 'refs';
3057 my ($pkg, @funs) = @$_; 3279 my ($pkg, @funs) = @$_;
3058 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3280 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
… …
3076 3298
3077 my $qcode = $code; 3299 my $qcode = $code;
3078 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3300 $qcode =~ s/"/‟/g; # not allowed in #line filenames
3079 $qcode =~ s/\n/\\n/g; 3301 $qcode =~ s/\n/\\n/g;
3080 3302
3303 %vars = (_dummy => 0) unless %vars;
3304
3305 my @res;
3081 local $_; 3306 local $_;
3082 local @safe::cf::_safe_eval_args = values %vars;
3083 3307
3084 my $eval = 3308 my $eval =
3085 "do {\n" 3309 "do {\n"
3086 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3310 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
3087 . "#line 0 \"{$qcode}\"\n" 3311 . "#line 0 \"{$qcode}\"\n"
3088 . $code 3312 . $code
3089 . "\n}" 3313 . "\n}"
3090 ; 3314 ;
3091 3315
3316 if ($CFG{safe_eval}) {
3092 sub_generation_inc; 3317 sub_generation_inc;
3318 local @safe::cf::_safe_eval_args = values %vars;
3093 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3319 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
3094 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 }
3095 3325
3096 if ($@) { 3326 if ($@) {
3097 warn "$@"; 3327 warn "$@",
3098 warn "while executing safe code '$code'\n"; 3328 "while executing safe code '$code'\n",
3099 warn "with arguments " . (join " ", %vars) . "\n"; 3329 "with arguments " . (join " ", %vars) . "\n";
3100 } 3330 }
3101 3331
3102 wantarray ? @res : $res[0] 3332 wantarray ? @res : $res[0]
3103} 3333}
3104 3334
… …
3118=cut 3348=cut
3119 3349
3120sub register_script_function { 3350sub register_script_function {
3121 my ($fun, $cb) = @_; 3351 my ($fun, $cb) = @_;
3122 3352
3123 no strict 'refs'; 3353 $fun = "safe::$fun" if $CFG{safe_eval};
3124 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3354 *$fun = $safe_hole->wrap ($cb);
3125} 3355}
3126 3356
3127=back 3357=back
3128 3358
3129=cut 3359=cut
… …
3138 # for this (global event?) 3368 # for this (global event?)
3139 %ext::player_env::MUSIC_FACE_CACHE = (); 3369 %ext::player_env::MUSIC_FACE_CACHE = ();
3140 3370
3141 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3371 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3142 3372
3143 warn "loading facedata from $path\n"; 3373 trace "loading facedata from $path\n";
3144 3374
3145 my $facedata; 3375 my $facedata;
3146 0 < aio_load $path, $facedata 3376 0 < aio_load $path, $facedata
3147 or die "$path: $!"; 3377 or die "$path: $!";
3148 3378
… …
3150 3380
3151 $facedata->{version} == 2 3381 $facedata->{version} == 2
3152 or cf::cleanup "$path: version mismatch, cannot proceed."; 3382 or cf::cleanup "$path: version mismatch, cannot proceed.";
3153 3383
3154 # 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]);
3155 $facedata->{resource}{"res/exp_table"} = { 3386 $facedata->{resource}{"res/exp_table"} = {
3156 type => FT_RSRC, 3387 type => FT_RSRC,
3157 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),
3158 }; 3390 };
3159 cf::cede_to_tick; 3391 cf::cede_to_tick;
3160 3392
3161 { 3393 {
3162 my $faces = $facedata->{faceinfo}; 3394 my $faces = $facedata->{faceinfo};
… …
3164 while (my ($face, $info) = each %$faces) { 3396 while (my ($face, $info) = each %$faces) {
3165 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3397 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3166 3398
3167 cf::face::set_visibility $idx, $info->{visibility}; 3399 cf::face::set_visibility $idx, $info->{visibility};
3168 cf::face::set_magicmap $idx, $info->{magicmap}; 3400 cf::face::set_magicmap $idx, $info->{magicmap};
3169 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3401 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3170 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3402 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3171 3403
3172 cf::cede_to_tick; 3404 cf::cede_to_tick;
3173 } 3405 }
3174 3406
3175 while (my ($face, $info) = each %$faces) { 3407 while (my ($face, $info) = each %$faces) {
… …
3180 3412
3181 if (my $smooth = cf::face::find $info->{smooth}) { 3413 if (my $smooth = cf::face::find $info->{smooth}) {
3182 cf::face::set_smooth $idx, $smooth; 3414 cf::face::set_smooth $idx, $smooth;
3183 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3415 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3184 } else { 3416 } else {
3185 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3417 error "smooth face '$info->{smooth}' not found for face '$face'";
3186 } 3418 }
3187 3419
3188 cf::cede_to_tick; 3420 cf::cede_to_tick;
3189 } 3421 }
3190 } 3422 }
… …
3199 3431
3200 cf::anim::invalidate_all; # d'oh 3432 cf::anim::invalidate_all; # d'oh
3201 } 3433 }
3202 3434
3203 { 3435 {
3204 # TODO: for gcfclient pleasure, we should give resources
3205 # that gcfclient doesn't grok a >10000 face index.
3206 my $res = $facedata->{resource}; 3436 my $res = $facedata->{resource};
3207 3437
3208 while (my ($name, $info) = each %$res) { 3438 while (my ($name, $info) = each %$res) {
3209 if (defined $info->{type}) { 3439 if (defined $info->{type}) {
3210 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3440 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3211 my $data;
3212 3441
3213 if ($info->{type} & 1) { 3442 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3214 # prepend meta info
3215
3216 my $meta = $enc->encode ({
3217 name => $name,
3218 %{ $info->{meta} || {} },
3219 });
3220
3221 $data = pack "(w/a*)*", $meta, $info->{data};
3222 } else {
3223 $data = $info->{data};
3224 }
3225
3226 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3227 cf::face::set_type $idx, $info->{type}; 3443 cf::face::set_type $idx, $info->{type};
3228 } else { 3444 } else {
3229 $RESOURCE{$name} = $info; 3445 $RESOURCE{$name} = $info; # unused
3230 } 3446 }
3231 3447
3232 cf::cede_to_tick; 3448 cf::cede_to_tick;
3233 } 3449 }
3234 } 3450 }
3235 3451
3236 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3452 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3237 3453
3238 1 3454 1
3239} 3455}
3240
3241cf::global->attach (on_resource_update => sub {
3242 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3243 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3244
3245 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3246 my $sound = $soundconf->{compat}[$_]
3247 or next;
3248
3249 my $face = cf::face::find "sound/$sound->[1]";
3250 cf::sound::set $sound->[0] => $face;
3251 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3252 }
3253
3254 while (my ($k, $v) = each %{$soundconf->{event}}) {
3255 my $face = cf::face::find "sound/$v";
3256 cf::sound::set $k => $face;
3257 }
3258 }
3259});
3260 3456
3261register_exticmd fx_want => sub { 3457register_exticmd fx_want => sub {
3262 my ($ns, $want) = @_; 3458 my ($ns, $want) = @_;
3263 3459
3264 while (my ($k, $v) = each %$want) { 3460 while (my ($k, $v) = each %$want) {
3265 $ns->fx_want ($k, $v); 3461 $ns->fx_want ($k, $v);
3266 } 3462 }
3267}; 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}
3268 3474
3269sub reload_regions { 3475sub reload_regions {
3270 # 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
3271 # for this (global event?) 3477 # for this (global event?)
3272 %ext::player_env::MUSIC_FACE_CACHE = (); 3478 %ext::player_env::MUSIC_FACE_CACHE = ();
… …
3286} 3492}
3287 3493
3288sub reload_archetypes { 3494sub reload_archetypes {
3289 load_resource_file "$DATADIR/archetypes" 3495 load_resource_file "$DATADIR/archetypes"
3290 or die "unable to load archetypes\n"; 3496 or die "unable to load archetypes\n";
3291 #d# NEED to laod twice to resolve forward references
3292 # this really needs to be done in an extra post-pass
3293 # (which needs to be synchronous, so solve it differently)
3294 load_resource_file "$DATADIR/archetypes"
3295 or die "unable to load archetypes\n";
3296} 3497}
3297 3498
3298sub reload_treasures { 3499sub reload_treasures {
3299 load_resource_file "$DATADIR/treasures" 3500 load_resource_file "$DATADIR/treasures"
3300 or die "unable to load treasurelists\n"; 3501 or die "unable to load treasurelists\n";
3301} 3502}
3302 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
3303sub reload_resources { 3527sub reload_resources {
3304 warn "reloading resource files...\n"; 3528 trace "reloading resource files...\n";
3305 3529
3530 reload_facedata;
3531 reload_sound;
3532 reload_archetypes;
3306 reload_regions; 3533 reload_regions;
3307 reload_facedata;
3308 #reload_archetypes;#d#
3309 reload_archetypes;
3310 reload_treasures; 3534 reload_treasures;
3311 3535
3312 warn "finished reloading resource files\n"; 3536 trace "finished reloading resource files\n";
3313}
3314
3315sub init {
3316 reload_resources;
3317} 3537}
3318 3538
3319sub reload_config { 3539sub reload_config {
3540 trace "reloading config file...\n";
3541
3320 open my $fh, "<:utf8", "$CONFDIR/config" 3542 open my $fh, "<:utf8", "$CONFDIR/config"
3321 or return; 3543 or return;
3322 3544
3323 local $/; 3545 local $/;
3324 *CFG = YAML::Load <$fh>; 3546 *CFG = YAML::XS::Load scalar <$fh>;
3325 3547
3326 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3548 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3327 3549
3328 $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};
3329 $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};
3330 3552
3331 if (exists $CFG{mlockall}) { 3553 if (exists $CFG{mlockall}) {
… …
3333 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3555 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3334 and die "WARNING: m(un)lockall failed: $!\n"; 3556 and die "WARNING: m(un)lockall failed: $!\n";
3335 }; 3557 };
3336 warn $@ if $@; 3558 warn $@ if $@;
3337 } 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;
3338} 3590}
3339 3591
3340sub main { 3592sub main {
3593 cf::init_globals; # initialise logging
3594
3595 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3596 LOG llevInfo, "Copyright (C) 2005-2008 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
3341 # we must not ever block the main coroutine 3602 # we must not ever block the main coroutine
3342 local $Coro::idle = sub { 3603 local $Coro::idle = sub {
3343 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#
3344 (async { 3605 (async {
3345 $Coro::current->{desc} = "IDLE BUG HANDLER"; 3606 $Coro::current->{desc} = "IDLE BUG HANDLER";
3346 EV::loop EV::LOOP_ONESHOT; 3607 EV::loop EV::LOOP_ONESHOT;
3347 })->prio (Coro::PRIO_MAX); 3608 })->prio (Coro::PRIO_MAX);
3348 }; 3609 };
3349 3610
3611 evthread_start IO::AIO::poll_fileno;
3612
3613 cf::sync_job {
3614 cf::init_experience;
3615 cf::init_anim;
3616 cf::init_attackmess;
3617 cf::init_dynamic;
3618
3619 cf::load_settings;
3620 cf::load_materials;
3621
3622 reload_resources;
3350 reload_config; 3623 reload_config;
3351 db_init; 3624 db_init;
3625
3626 cf::init_uuid;
3627 cf::init_signals;
3628 cf::init_skills;
3629
3630 cf::init_beforeplay;
3631
3632 atomic;
3633
3352 load_extensions; 3634 load_extensions;
3353 3635
3354 $TICK_WATCHER->start; 3636 utime time, time, $RUNTIMEFILE;
3355 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3637
3356 EV::loop; 3638 # no (long-running) fork's whatsoever before this point(!)
3639 use POSIX ();
3640 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3641
3642 (pop @POST_INIT)->(0) while @POST_INIT;
3643 };
3644
3645 cf::object::thawer::errors_are_fatal 0;
3646 info "parse errors in files are no longer fatal from this point on.\n";
3647
3648 main_loop;
3357} 3649}
3358 3650
3359############################################################################# 3651#############################################################################
3360# initialisation and cleanup 3652# initialisation and cleanup
3361 3653
3362# install some emergency cleanup handlers 3654# install some emergency cleanup handlers
3363BEGIN { 3655BEGIN {
3364 our %SIGWATCHER = (); 3656 our %SIGWATCHER = ();
3365 for my $signal (qw(INT HUP TERM)) { 3657 for my $signal (qw(INT HUP TERM)) {
3366 $SIGWATCHER{$signal} = EV::signal $signal, sub { 3658 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3367 cf::cleanup "SIG$signal"; 3659 cf::cleanup "SIG$signal";
3368 }; 3660 };
3369 } 3661 }
3370} 3662}
3371 3663
3372sub write_runtime { 3664sub write_runtime_sync {
3373 my $runtime = "$LOCALDIR/runtime"; 3665 my $t0 = AE::time;
3374 3666
3375 # first touch the runtime file to show we are still running: 3667 # first touch the runtime file to show we are still running:
3376 # the fsync below can take a very very long time. 3668 # the fsync below can take a very very long time.
3377 3669
3378 IO::AIO::aio_utime $runtime, undef, undef; 3670 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3379 3671
3380 my $guard = cf::lock_acquire "write_runtime"; 3672 my $guard = cf::lock_acquire "write_runtime";
3381 3673
3382 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3674 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3383 or return; 3675 or return;
3384 3676
3385 my $value = $cf::RUNTIME + 90 + 10; 3677 my $value = $cf::RUNTIME + 90 + 10;
3386 # 10 is the runtime save interval, for a monotonic clock 3678 # 10 is the runtime save interval, for a monotonic clock
3387 # 60 allows for the watchdog to kill the server. 3679 # 60 allows for the watchdog to kill the server.
… …
3397 aio_utime $fh, undef, undef; 3689 aio_utime $fh, undef, undef;
3398 3690
3399 close $fh 3691 close $fh
3400 or return; 3692 or return;
3401 3693
3402 aio_rename "$runtime~", $runtime 3694 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3403 and return; 3695 and return;
3404 3696
3405 warn "runtime file written.\n"; 3697 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3406 3698
3407 1 3699 1
3700}
3701
3702our $uuid_lock;
3703our $uuid_skip;
3704
3705sub write_uuid_sync($) {
3706 $uuid_skip ||= $_[0];
3707
3708 return if $uuid_lock;
3709 local $uuid_lock = 1;
3710
3711 my $uuid = "$LOCALDIR/uuid";
3712
3713 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3714 or return;
3715
3716 my $value = uuid_seq uuid_cur;
3717
3718 unless ($value) {
3719 info "cowardly refusing to write zero uuid value!\n";
3720 return;
3721 }
3722
3723 my $value = uuid_str $value + $uuid_skip;
3724 $uuid_skip = 0;
3725
3726 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3727 and return;
3728
3729 # always fsync - this file is important
3730 aio_fsync $fh
3731 and return;
3732
3733 close $fh
3734 or return;
3735
3736 aio_rename "$uuid~", $uuid
3737 and return;
3738
3739 trace "uuid file written ($value).\n";
3740
3741 1
3742
3743}
3744
3745sub write_uuid($$) {
3746 my ($skip, $sync) = @_;
3747
3748 $sync ? write_uuid_sync $skip
3749 : async { write_uuid_sync $skip };
3408} 3750}
3409 3751
3410sub emergency_save() { 3752sub emergency_save() {
3411 my $freeze_guard = cf::freeze_mainloop; 3753 my $freeze_guard = cf::freeze_mainloop;
3412 3754
3413 warn "enter emergency perl save\n"; 3755 info "emergency_perl_save: enter\n";
3756
3757 # this is a trade-off: we want to be very quick here, so
3758 # save all maps without fsync, and later call a global sync
3759 # (which in turn might be very very slow)
3760 local $USE_FSYNC = 0;
3414 3761
3415 cf::sync_job { 3762 cf::sync_job {
3416 # use a peculiar iteration method to avoid tripping on perl 3763 # use a peculiar iteration method to avoid tripping on perl
3417 # refcount bugs in for. also avoids problems with players 3764 # refcount bugs in for. also avoids problems with players
3418 # and maps saved/destroyed asynchronously. 3765 # and maps saved/destroyed asynchronously.
3419 warn "begin emergency player save\n"; 3766 info "emergency_perl_save: begin player save\n";
3420 for my $login (keys %cf::PLAYER) { 3767 for my $login (keys %cf::PLAYER) {
3421 my $pl = $cf::PLAYER{$login} or next; 3768 my $pl = $cf::PLAYER{$login} or next;
3422 $pl->valid or next; 3769 $pl->valid or next;
3423 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3770 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3424 $pl->save; 3771 $pl->save;
3425 } 3772 }
3426 warn "end emergency player save\n"; 3773 info "emergency_perl_save: end player save\n";
3427 3774
3428 warn "begin emergency map save\n"; 3775 info "emergency_perl_save: begin map save\n";
3429 for my $path (keys %cf::MAP) { 3776 for my $path (keys %cf::MAP) {
3430 my $map = $cf::MAP{$path} or next; 3777 my $map = $cf::MAP{$path} or next;
3431 $map->valid or next; 3778 $map->valid or next;
3432 $map->save; 3779 $map->save;
3433 } 3780 }
3434 warn "end emergency map save\n"; 3781 info "emergency_perl_save: end map save\n";
3435 3782
3436 warn "begin emergency database checkpoint\n"; 3783 info "emergency_perl_save: begin database checkpoint\n";
3437 BDB::db_env_txn_checkpoint $DB_ENV; 3784 BDB::db_env_txn_checkpoint $DB_ENV;
3438 warn "end emergency database checkpoint\n"; 3785 info "emergency_perl_save: end database checkpoint\n";
3786
3787 info "emergency_perl_save: begin write uuid\n";
3788 write_uuid_sync 1;
3789 info "emergency_perl_save: end write uuid\n";
3439 }; 3790 };
3440 3791
3441 warn "leave emergency perl save\n"; 3792 info "emergency_perl_save: starting sync()\n";
3793 IO::AIO::aio_sync sub {
3794 info "emergency_perl_save: finished sync()\n";
3795 };
3796
3797 info "emergency_perl_save: leave\n";
3442} 3798}
3443 3799
3444sub post_cleanup { 3800sub post_cleanup {
3445 my ($make_core) = @_; 3801 my ($make_core) = @_;
3446 3802
3447 warn Carp::longmess "post_cleanup backtrace" 3803 error Carp::longmess "post_cleanup backtrace"
3448 if $make_core; 3804 if $make_core;
3805
3806 my $fh = pidfile;
3807 unlink $PIDFILE if <$fh> == $$;
3808}
3809
3810# a safer delete_package, copied from Symbol
3811sub clear_package($) {
3812 my $pkg = shift;
3813
3814 # expand to full symbol table name if needed
3815 unless ($pkg =~ /^main::.*::$/) {
3816 $pkg = "main$pkg" if $pkg =~ /^::/;
3817 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3818 $pkg .= '::' unless $pkg =~ /::$/;
3819 }
3820
3821 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3822 my $stem_symtab = *{$stem}{HASH};
3823
3824 defined $stem_symtab and exists $stem_symtab->{$leaf}
3825 or return;
3826
3827 # clear all symbols
3828 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3829 for my $name (keys %$leaf_symtab) {
3830 _gv_clear *{"$pkg$name"};
3831# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3832 }
3449} 3833}
3450 3834
3451sub do_reload_perl() { 3835sub do_reload_perl() {
3452 # can/must only be called in main 3836 # can/must only be called in main
3453 if ($Coro::current != $Coro::main) { 3837 if (in_main) {
3454 warn "can only reload from main coroutine"; 3838 error "can only reload from main coroutine";
3455 return; 3839 return;
3456 } 3840 }
3457 3841
3842 return if $RELOAD++;
3843
3844 my $t1 = AE::time;
3845
3846 while ($RELOAD) {
3458 warn "reloading..."; 3847 info "reloading...";
3459 3848
3460 warn "entering sync_job"; 3849 trace "entering sync_job";
3461 3850
3462 cf::sync_job { 3851 cf::sync_job {
3463 cf::write_runtime; # external watchdog should not bark 3852 cf::write_runtime_sync; # external watchdog should not bark
3464 cf::emergency_save; 3853 cf::emergency_save;
3465 cf::write_runtime; # external watchdog should not bark 3854 cf::write_runtime_sync; # external watchdog should not bark
3466 3855
3467 warn "syncing database to disk"; 3856 trace "syncing database to disk";
3468 BDB::db_env_txn_checkpoint $DB_ENV; 3857 BDB::db_env_txn_checkpoint $DB_ENV;
3469 3858
3470 # if anything goes wrong in here, we should simply crash as we already saved 3859 # if anything goes wrong in here, we should simply crash as we already saved
3471 3860
3472 warn "flushing outstanding aio requests"; 3861 trace "flushing outstanding aio requests";
3473 for (;;) {
3474 BDB::flush;
3475 IO::AIO::flush;
3476 Coro::cede_notself;
3477 last unless IO::AIO::nreqs || BDB::nreqs; 3862 while (IO::AIO::nreqs || BDB::nreqs) {
3478 warn "iterate..."; 3863 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3479 }
3480
3481 ++$RELOAD;
3482
3483 warn "cancelling all extension coros";
3484 $_->cancel for values %EXT_CORO;
3485 %EXT_CORO = ();
3486
3487 warn "removing commands";
3488 %COMMAND = ();
3489
3490 warn "removing ext/exti commands";
3491 %EXTCMD = ();
3492 %EXTICMD = ();
3493
3494 warn "unloading/nuking all extensions";
3495 for my $pkg (@EXTS) {
3496 warn "... unloading $pkg";
3497
3498 if (my $cb = $pkg->can ("unload")) {
3499 eval {
3500 $cb->($pkg);
3501 1
3502 } or warn "$pkg unloaded, but with errors: $@";
3503 } 3864 }
3504 3865
3505 warn "... nuking $pkg"; 3866 trace "cancelling all extension coros";
3506 Symbol::delete_package $pkg; 3867 $_->cancel for values %EXT_CORO;
3507 } 3868 %EXT_CORO = ();
3508 3869
3509 warn "unloading all perl modules loaded from $LIBDIR"; 3870 trace "removing commands";
3510 while (my ($k, $v) = each %INC) { 3871 %COMMAND = ();
3511 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3512 3872
3873 trace "removing ext/exti commands";
3874 %EXTCMD = ();
3875 %EXTICMD = ();
3876
3877 trace "unloading/nuking all extensions";
3878 for my $pkg (@EXTS) {
3513 warn "... unloading $k"; 3879 trace "... unloading $pkg";
3514 delete $INC{$k};
3515 3880
3516 $k =~ s/\.pm$//;
3517 $k =~ s/\//::/g;
3518
3519 if (my $cb = $k->can ("unload_module")) { 3881 if (my $cb = $pkg->can ("unload")) {
3882 eval {
3520 $cb->(); 3883 $cb->($pkg);
3884 1
3885 } or error "$pkg unloaded, but with errors: $@";
3886 }
3887
3888 trace "... clearing $pkg";
3889 clear_package $pkg;
3521 } 3890 }
3522 3891
3523 Symbol::delete_package $k; 3892 trace "unloading all perl modules loaded from $LIBDIR";
3893 while (my ($k, $v) = each %INC) {
3894 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3895
3896 trace "... unloading $k";
3897 delete $INC{$k};
3898
3899 $k =~ s/\.pm$//;
3900 $k =~ s/\//::/g;
3901
3902 if (my $cb = $k->can ("unload_module")) {
3903 $cb->();
3904 }
3905
3906 clear_package $k;
3524 } 3907 }
3525 3908
3526 warn "getting rid of safe::, as good as possible"; 3909 trace "getting rid of safe::, as good as possible";
3527 Symbol::delete_package "safe::$_" 3910 clear_package "safe::$_"
3528 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3911 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3529 3912
3530 warn "unloading cf.pm \"a bit\""; 3913 trace "unloading cf.pm \"a bit\"";
3531 delete $INC{"cf.pm"}; 3914 delete $INC{"cf.pm"};
3532 delete $INC{"cf/pod.pm"}; 3915 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3533 3916
3534 # don't, removes xs symbols, too, 3917 # don't, removes xs symbols, too,
3535 # and global variables created in xs 3918 # and global variables created in xs
3536 #Symbol::delete_package __PACKAGE__; 3919 #clear_package __PACKAGE__;
3537 3920
3538 warn "unload completed, starting to reload now"; 3921 info "unload completed, starting to reload now";
3539 3922
3540 warn "reloading cf.pm"; 3923 trace "reloading cf.pm";
3541 require cf; 3924 require cf;
3542 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3925 cf::_connect_to_perl_1;
3543 3926
3544 warn "loading config and database again"; 3927 trace "loading config and database again";
3545 cf::reload_config; 3928 cf::reload_config;
3546 3929
3547 warn "loading extensions"; 3930 trace "loading extensions";
3548 cf::load_extensions; 3931 cf::load_extensions;
3549 3932
3933 if ($REATTACH_ON_RELOAD) {
3550 warn "reattaching attachments to objects/players"; 3934 trace "reattaching attachments to objects/players";
3551 _global_reattach; # objects, sockets 3935 _global_reattach; # objects, sockets
3552 warn "reattaching attachments to maps"; 3936 trace "reattaching attachments to maps";
3553 reattach $_ for values %MAP; 3937 reattach $_ for values %MAP;
3554 warn "reattaching attachments to players"; 3938 trace "reattaching attachments to players";
3555 reattach $_ for values %PLAYER; 3939 reattach $_ for values %PLAYER;
3940 }
3556 3941
3942 trace "running post_init jobs";
3943 (pop @POST_INIT)->(1) while @POST_INIT;
3944
3557 warn "leaving sync_job"; 3945 trace "leaving sync_job";
3558 3946
3559 1 3947 1
3560 } or do { 3948 } or do {
3561 warn $@; 3949 error $@;
3562 cf::cleanup "error while reloading, exiting."; 3950 cf::cleanup "error while reloading, exiting.";
3951 };
3952
3953 info "reloaded";
3954 --$RELOAD;
3563 }; 3955 }
3564 3956
3565 warn "reloaded"; 3957 $t1 = AE::time - $t1;
3958 info "reload completed in ${t1}s\n";
3566}; 3959};
3567 3960
3568our $RELOAD_WATCHER; # used only during reload 3961our $RELOAD_WATCHER; # used only during reload
3569 3962
3570sub reload_perl() { 3963sub reload_perl() {
3571 # doing reload synchronously and two reloads happen back-to-back, 3964 # doing reload synchronously and two reloads happen back-to-back,
3572 # coro crashes during coro_state_free->destroy here. 3965 # coro crashes during coro_state_free->destroy here.
3573 3966
3967 $RELOAD_WATCHER ||= cf::async {
3968 Coro::AIO::aio_wait cache_extensions;
3969
3574 $RELOAD_WATCHER ||= EV::timer 0, 0, sub { 3970 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3575 do_reload_perl; 3971 do_reload_perl;
3576 undef $RELOAD_WATCHER; 3972 undef $RELOAD_WATCHER;
3973 };
3577 }; 3974 };
3578} 3975}
3579 3976
3580register_command "reload" => sub { 3977register_command "reload" => sub {
3581 my ($who, $arg) = @_; 3978 my ($who, $arg) = @_;
… …
3595 3992
3596our @WAIT_FOR_TICK; 3993our @WAIT_FOR_TICK;
3597our @WAIT_FOR_TICK_BEGIN; 3994our @WAIT_FOR_TICK_BEGIN;
3598 3995
3599sub wait_for_tick { 3996sub wait_for_tick {
3600 return unless $TICK_WATCHER->is_active;
3601 return if $Coro::current == $Coro::main; 3997 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3602 3998
3603 my $signal = new Coro::Signal; 3999 my $signal = new Coro::Signal;
3604 push @WAIT_FOR_TICK, $signal; 4000 push @WAIT_FOR_TICK, $signal;
3605 $signal->wait; 4001 $signal->wait;
3606} 4002}
3607 4003
3608sub wait_for_tick_begin { 4004sub wait_for_tick_begin {
3609 return unless $TICK_WATCHER->is_active;
3610 return if $Coro::current == $Coro::main; 4005 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3611 4006
3612 my $signal = new Coro::Signal; 4007 my $signal = new Coro::Signal;
3613 push @WAIT_FOR_TICK_BEGIN, $signal; 4008 push @WAIT_FOR_TICK_BEGIN, $signal;
3614 $signal->wait; 4009 $signal->wait;
3615} 4010}
3616 4011
3617$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub { 4012sub tick {
3618 if ($Coro::current != $Coro::main) { 4013 if ($Coro::current != $Coro::main) {
3619 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4014 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3620 unless ++$bug_warning > 10; 4015 unless ++$bug_warning > 10;
3621 return; 4016 return;
3622 } 4017 }
3623 4018
3624 $NOW = $tick_start = EV::now;
3625
3626 cf::server_tick; # one server iteration 4019 cf::server_tick; # one server iteration
3627 4020
3628 $RUNTIME += $TICK; 4021 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3629 $NEXT_TICK = $_[0]->at;
3630 4022
3631 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4023 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3632 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4024 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3633 Coro::async_pool { 4025 Coro::async_pool {
3634 $Coro::current->{desc} = "runtime saver"; 4026 $Coro::current->{desc} = "runtime saver";
3635 write_runtime 4027 write_runtime_sync
3636 or warn "ERROR: unable to write runtime file: $!"; 4028 or error "ERROR: unable to write runtime file: $!";
3637 }; 4029 };
3638 } 4030 }
3639 4031
3640 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4032 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3641 $sig->send; 4033 $sig->send;
3642 } 4034 }
3643 while (my $sig = shift @WAIT_FOR_TICK) { 4035 while (my $sig = shift @WAIT_FOR_TICK) {
3644 $sig->send; 4036 $sig->send;
3645 } 4037 }
3646 4038
3647 $LOAD = ($NOW - $tick_start) / $TICK; 4039 $LOAD = ($NOW - $TICK_START) / $TICK;
3648 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4040 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3649 4041
3650 _post_tick; 4042 if (0) {
3651}; 4043 if ($NEXT_TICK) {
3652$TICK_WATCHER->priority (EV::MAXPRI); 4044 my $jitter = $TICK_START - $NEXT_TICK;
4045 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4046 debug "jitter $JITTER\n";#d#
4047 }
4048 }
4049}
3653 4050
3654{ 4051{
3655 # configure BDB 4052 # configure BDB
3656 4053
3657 BDB::min_parallel 8; 4054 BDB::min_parallel 16;
3658 BDB::max_poll_reqs $TICK * 0.1; 4055 BDB::max_poll_reqs $TICK * 0.1;
3659 $Coro::BDB::WATCHER->priority (1); 4056 $AnyEvent::BDB::WATCHER->priority (1);
3660 4057
3661 unless ($DB_ENV) { 4058 unless ($DB_ENV) {
3662 $DB_ENV = BDB::db_env_create; 4059 $DB_ENV = BDB::db_env_create;
3663 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC 4060 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
3664 | BDB::LOG_AUTOREMOVE, 1); 4061 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4062 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
3665 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT); 4063 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3666 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT); 4064 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3667 4065
3668 cf::sync_job { 4066 cf::sync_job {
3669 eval { 4067 eval {
… …
3695{ 4093{
3696 # configure IO::AIO 4094 # configure IO::AIO
3697 4095
3698 IO::AIO::min_parallel 8; 4096 IO::AIO::min_parallel 8;
3699 IO::AIO::max_poll_time $TICK * 0.1; 4097 IO::AIO::max_poll_time $TICK * 0.1;
3700 $Coro::AIO::WATCHER->priority (1); 4098 undef $AnyEvent::AIO::WATCHER;
3701} 4099}
3702 4100
3703my $_log_backtrace; 4101my $_log_backtrace;
3704 4102
3705sub _log_backtrace { 4103sub _log_backtrace {
… …
3708 $msg =~ s/\n//; 4106 $msg =~ s/\n//;
3709 4107
3710 # limit the # of concurrent backtraces 4108 # limit the # of concurrent backtraces
3711 if ($_log_backtrace < 2) { 4109 if ($_log_backtrace < 2) {
3712 ++$_log_backtrace; 4110 ++$_log_backtrace;
4111 my $perl_bt = Carp::longmess $msg;
3713 async { 4112 async {
3714 $Coro::current->{desc} = "abt $msg"; 4113 $Coro::current->{desc} = "abt $msg";
3715 4114
3716 my @bt = fork_call { 4115 my @bt = fork_call {
3717 @addr = map { sprintf "%x", $_ } @addr; 4116 @addr = map { sprintf "%x", $_ } @addr;
… …
3728 } 4127 }
3729 4128
3730 @funcs 4129 @funcs
3731 }; 4130 };
3732 4131
3733 LOG llevInfo, "[ABT] $msg\n"; 4132 LOG llevInfo, "[ABT] $perl_bt\n";
4133 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3734 LOG llevInfo, "[ABT] $_\n" for @bt; 4134 LOG llevInfo, "[ABT] $_\n" for @bt;
3735 --$_log_backtrace; 4135 --$_log_backtrace;
3736 }; 4136 };
3737 } else { 4137 } else {
3738 LOG llevInfo, "[ABT] $msg\n"; 4138 LOG llevInfo, "[ABT] $msg\n";
3739 LOG llevInfo, "[ABT] [suppressed]\n"; 4139 LOG llevInfo, "[ABT] [suppressed]\n";
3740 } 4140 }
3741} 4141}
3742 4142
3743# load additional modules 4143# load additional modules
3744use cf::pod; 4144require "cf/$_.pm" for @EXTRA_MODULES;
4145cf::_connect_to_perl_2;
3745 4146
3746END { cf::emergency_save } 4147END { cf::emergency_save }
3747 4148
37481 41491
3749 4150

Diff Legend

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