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.441 by root, Sat Aug 30 05:19:03 2008 UTC vs.
Revision 1.545 by root, Thu May 6 22:35:41 2010 UTC

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

Diff Legend

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