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.267 by root, Sat May 19 00:08:11 2007 UTC vs.
Revision 1.539 by root, Tue May 4 22:49:21 2010 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
3use utf8; 25use common::sense;
4use strict;
5 26
6use Symbol; 27use Symbol;
7use List::Util; 28use List::Util;
8use Socket; 29use Socket;
9use Storable; 30use EV;
10use Event;
11use Opcode; 31use Opcode;
12use Safe; 32use Safe;
13use Safe::Hole; 33use Safe::Hole;
34use Storable ();
35use Carp ();
14 36
37use Guard ();
15use Coro 3.61 (); 38use Coro ();
16use Coro::State; 39use Coro::State;
17use Coro::Handle; 40use Coro::Handle;
41use Coro::EV;
18use Coro::Event; 42use Coro::AnyEvent;
19use Coro::Timer; 43use Coro::Timer;
20use Coro::Signal; 44use Coro::Signal;
21use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
22use Coro::AIO; 48use Coro::AIO;
49use Coro::BDB 1.6;
23use Coro::Storable; 50use Coro::Storable;
51use Coro::Util ();
24 52
53use JSON::XS 2.01 ();
25use BDB (); 54use BDB ();
26use Data::Dumper; 55use Data::Dumper;
27use Digest::MD5;
28use Fcntl; 56use Fcntl;
29use YAML::Syck (); 57use YAML::XS ();
30use IO::AIO 2.32 (); 58use IO::AIO ();
31use Time::HiRes; 59use Time::HiRes;
32use Compress::LZF; 60use Compress::LZF;
61use Digest::MD5 ();
62
63AnyEvent::detect;
33 64
34# configure various modules to our taste 65# configure various modules to our taste
35# 66#
36$Storable::canonical = 1; # reduce rsync transfers 67$Storable::canonical = 1; # reduce rsync transfers
37Coro::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";
38Compress::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
39 75
40$Event::Eval = 1; # no idea why this is required, but it is 76# strictly for debugging
41 77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
43$YAML::Syck::ImplicitUnicode = 1;
44
45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46 78
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
48 80
49our %COMMAND = (); 81our %COMMAND = ();
50our %COMMAND_TIME = (); 82our %COMMAND_TIME = ();
51 83
52our @EXTS = (); # list of extension package names 84our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 85our %EXTCMD = ();
86our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 87our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 88our %EXT_MAP = (); # pluggable maps
56 89
57our $RELOAD; # number of reloads so far 90our $RELOAD; # number of reloads so far, non-zero while in reload
58our @EVENT; 91our @EVENT;
92our @REFLECT; # set by XS
93our %REFLECT; # set by us
59 94
60our $CONFDIR = confdir; 95our $CONFDIR = confdir;
61our $DATADIR = datadir; 96our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext"; 97our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod"; 98our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir; 99our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir; 100our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir; 101our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 102our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir; 103our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random"; 104our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db"; 105our $BDBDIR = "$LOCALDIR/db";
106our $PIDFILE = "$LOCALDIR/pid";
107our $RUNTIMEFILE = "$LOCALDIR/runtime";
108
109our %RESOURCE; # unused
110
111our $OUTPUT_RATE_MIN = 3000;
112our $OUTPUT_RATE_MAX = 1000000;
113
114our $MAX_LINKS = 32; # how many chained exits to follow
115our $VERBOSE_IO = 1;
71 116
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 117our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 118our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
76our $NEXT_TICK; 119our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 120our $USE_FSYNC = 1; # use fsync to write maps - default on
79 121
122our $BDB_DEADLOCK_WATCHER;
123our $BDB_CHECKPOINT_WATCHER;
80our $BDB_POLL_WATCHER; 124our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 125our $DB_ENV;
126
127our @EXTRA_MODULES = qw(pod match mapscript);
82 128
83our %CFG; 129our %CFG;
84 130
85our $UPTIME; $UPTIME ||= time; 131our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 132our $RUNTIME;
133our $NOW;
87 134
88our %PLAYER; # all users 135our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 136our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 137our $LINK_MAP; # the special {link} map, which is always available
91 138
92# used to convert map paths into valid unix filenames by replacing / by ∕ 139# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 140our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 141
95our $LOAD; # a number between 0 (idle) and 1 (too many objects) 142our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing 143our $LOADAVG; # same thing, but with alpha-smoothing
144our $JITTER; # average jitter
97our $tick_start; # for load detecting purposes 145our $TICK_START; # for load detecting purposes
146
147our @POST_INIT;
148
149our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
150our $REALLY_UNLOOP; # never set to true, please :)
98 151
99binmode STDOUT; 152binmode STDOUT;
100binmode STDERR; 153binmode STDERR;
101 154
102# read virtual server time, if available 155# read virtual server time, if available
103unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 156unless ($RUNTIME || !-e $RUNTIMEFILE) {
104 open my $fh, "<", "$LOCALDIR/runtime" 157 open my $fh, "<", $RUNTIMEFILE
105 or die "unable to read runtime file: $!"; 158 or die "unable to read $RUNTIMEFILE file: $!";
106 $RUNTIME = <$fh> + 0.; 159 $RUNTIME = <$fh> + 0.;
107} 160}
161
162eval "sub TICK() { $TICK } 1" or die;
108 163
109mkdir $_ 164mkdir $_
110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 165 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
111 166
112our $EMERGENCY_POSITION; 167our $EMERGENCY_POSITION;
113 168
114sub cf::map::normalise; 169sub cf::map::normalise;
170
171sub in_main() {
172 $Coro::current == $Coro::main
173}
174
175#############################################################################
176
177%REFLECT = ();
178for (@REFLECT) {
179 my $reflect = JSON::XS::decode_json $_;
180 $REFLECT{$reflect->{class}} = $reflect;
181}
182
183# this is decidedly evil
184$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
115 185
116############################################################################# 186#############################################################################
117 187
118=head2 GLOBAL VARIABLES 188=head2 GLOBAL VARIABLES
119 189
… …
155 225
156The raw value load value from the last tick. 226The raw value load value from the last tick.
157 227
158=item %cf::CFG 228=item %cf::CFG
159 229
160Configuration for the server, loaded from C</etc/crossfire/config>, or 230Configuration for the server, loaded from C</etc/deliantra-server/config>, or
161from wherever your confdir points to. 231from wherever your confdir points to.
162 232
163=item cf::wait_for_tick, cf::wait_for_tick_begin 233=item cf::wait_for_tick, cf::wait_for_tick_begin
164 234
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 235These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166returns directly I<after> the tick processing (and consequently, can only wake one process 236returns directly I<after> the tick processing (and consequently, can only wake one process
167per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 237per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168 238
239=item @cf::INVOKE_RESULTS
240
241This array contains the results of the last C<invoke ()> call. When
242C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
243that call.
244
245=item %cf::REFLECT
246
247Contains, for each (C++) class name, a hash reference with information
248about object members (methods, scalars, arrays and flags) and other
249metadata, which is useful for introspection.
250
169=back 251=back
170 252
171=cut 253=cut
172 254
173BEGIN { 255sub error(@) { LOG llevError, join "", @_ }
174 *CORE::GLOBAL::warn = sub { 256sub warn (@) { LOG llevWarn , join "", @_ }
257sub info (@) { LOG llevInfo , join "", @_ }
258sub debug(@) { LOG llevDebug, join "", @_ }
259sub trace(@) { LOG llevTrace, join "", @_ }
260
261$Coro::State::WARNHOOK = sub {
175 my $msg = join "", @_; 262 my $msg = join "", @_;
176 263
177 $msg .= "\n" 264 $msg .= "\n"
178 unless $msg =~ /\n$/; 265 unless $msg =~ /\n$/;
179 266
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 267 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181 268
182 utf8::encode $msg;
183 LOG llevError, $msg; 269 LOG llevWarn, $msg;
184 }; 270};
185} 271
272$Coro::State::DIEHOOK = sub {
273 return unless $^S eq 0; # "eq", not "=="
274
275 error Carp::longmess $_[0];
276
277 if (in_main) {#d#
278 error "DIEHOOK called in main context, Coro bug?\n";#d#
279 return;#d#
280 }#d#
281
282 # kill coroutine otherwise
283 Coro::terminate
284};
186 285
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 286@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 287@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 288@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 289@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 290@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
291@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
192@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 292@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
193 293
194# we bless all objects into (empty) derived classes to force a method lookup 294# we bless all objects into (empty) derived classes to force a method lookup
195# within the Safe compartment. 295# within the Safe compartment.
196for my $pkg (qw( 296for my $pkg (qw(
197 cf::global cf::attachable 297 cf::global cf::attachable
198 cf::object cf::object::player 298 cf::object cf::object::player
199 cf::client cf::player 299 cf::client cf::player
200 cf::arch cf::living 300 cf::arch cf::living
301 cf::map cf::mapspace
201 cf::map cf::party cf::region 302 cf::party cf::region
202)) { 303)) {
203 no strict 'refs';
204 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 304 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
205} 305}
206 306
207$Event::DIED = sub { 307$EV::DIED = sub {
208 warn "error in event callback: @_"; 308 Carp::cluck "error in event callback: @_";
209}; 309};
310
311#############################################################################
210 312
211=head2 UTILITY FUNCTIONS 313=head2 UTILITY FUNCTIONS
212 314
213=over 4 315=over 4
214 316
… …
233 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 335 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
234 $d 336 $d
235 } || "[unable to dump $_[0]: '$@']"; 337 } || "[unable to dump $_[0]: '$@']";
236} 338}
237 339
238use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
239
240=item $ref = cf::from_json $json 340=item $ref = cf::decode_json $json
241 341
242Converts a JSON string into the corresponding perl data structure. 342Converts a JSON string into the corresponding perl data structure.
243 343
244=item $json = cf::to_json $ref 344=item $json = cf::encode_json $ref
245 345
246Converts a perl data structure into its JSON representation. 346Converts a perl data structure into its JSON representation.
247 347
348=cut
349
350our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
351
352sub encode_json($) { $json_coder->encode ($_[0]) }
353sub decode_json($) { $json_coder->decode ($_[0]) }
354
355=item cf::post_init { BLOCK }
356
357Execute the given codeblock, I<after> all extensions have been (re-)loaded,
358but I<before> the server starts ticking again.
359
360The cdoeblock will have a single boolean argument to indicate whether this
361is a reload or not.
362
363=cut
364
365sub post_init(&) {
366 push @POST_INIT, shift;
367}
368
248=item cf::lock_wait $string 369=item cf::lock_wait $string
249 370
250Wait until the given lock is available. See cf::lock_acquire. 371Wait until the given lock is available. See cf::lock_acquire.
251 372
252=item my $lock = cf::lock_acquire $string 373=item my $lock = cf::lock_acquire $string
253 374
254Wait until the given lock is available and then acquires it and returns 375Wait until the given lock is available and then acquires it and returns
255a Coro::guard object. If the guard object gets destroyed (goes out of scope, 376a L<Guard> object. If the guard object gets destroyed (goes out of scope,
256for example when the coroutine gets canceled), the lock is automatically 377for example when the coroutine gets canceled), the lock is automatically
257returned. 378returned.
258 379
380Locks are *not* recursive, locking from the same coro twice results in a
381deadlocked coro.
382
259Lock names should begin with a unique identifier (for example, cf::map::find 383Lock names should begin with a unique identifier (for example, cf::map::find
260uses map_find and cf::map::load uses map_load). 384uses map_find and cf::map::load uses map_load).
261 385
262=item $locked = cf::lock_active $string 386=item $locked = cf::lock_active $string
263 387
264Return true if the lock is currently active, i.e. somebody has locked it. 388Return true if the lock is currently active, i.e. somebody has locked it.
265 389
266=cut 390=cut
267 391
268our %LOCK; 392our $LOCKS = new Coro::SemaphoreSet;
269 393
270sub lock_wait($) { 394sub lock_wait($) {
271 my ($key) = @_; 395 $LOCKS->wait ($_[0]);
272
273 # wait for lock, if any
274 while ($LOCK{$key}) {
275 push @{ $LOCK{$key} }, $Coro::current;
276 Coro::schedule;
277 }
278} 396}
279 397
280sub lock_acquire($) { 398sub lock_acquire($) {
281 my ($key) = @_; 399 $LOCKS->guard ($_[0])
282
283 # wait, to be sure we are not locked
284 lock_wait $key;
285
286 $LOCK{$key} = [];
287
288 Coro::guard {
289 # wake up all waiters, to be on the safe side
290 $_->ready for @{ delete $LOCK{$key} };
291 }
292} 400}
293 401
294sub lock_active($) { 402sub lock_active($) {
295 my ($key) = @_; 403 $LOCKS->count ($_[0]) < 1
296
297 ! ! $LOCK{$key}
298} 404}
299 405
300sub freeze_mainloop { 406sub freeze_mainloop {
301 return unless $TICK_WATCHER->is_active; 407 tick_inhibit_inc;
302 408
303 my $guard = Coro::guard { 409 &Guard::guard (\&tick_inhibit_dec);
304 $TICK_WATCHER->start; 410}
411
412=item cf::periodic $interval, $cb
413
414Like EV::periodic, but randomly selects a starting point so that the actions
415get spread over time.
416
417=cut
418
419sub periodic($$) {
420 my ($interval, $cb) = @_;
421
422 my $start = rand List::Util::min 180, $interval;
423
424 EV::periodic $start, $interval, 0, $cb
425}
426
427=item cf::get_slot $time[, $priority[, $name]]
428
429Allocate $time seconds of blocking CPU time at priority C<$priority>:
430This call blocks and returns only when you have at least C<$time> seconds
431of cpu time till the next tick. The slot is only valid till the next cede.
432
433The optional C<$name> can be used to identify the job to run. It might be
434used for statistical purposes and should identify the same time-class.
435
436Useful for short background jobs.
437
438=cut
439
440our @SLOT_QUEUE;
441our $SLOT_QUEUE;
442our $SLOT_DECAY = 0.9;
443
444$SLOT_QUEUE->cancel if $SLOT_QUEUE;
445$SLOT_QUEUE = Coro::async {
446 $Coro::current->desc ("timeslot manager");
447
448 my $signal = new Coro::Signal;
449 my $busy;
450
451 while () {
452 next_job:
453
454 my $avail = cf::till_tick;
455
456 for (0 .. $#SLOT_QUEUE) {
457 if ($SLOT_QUEUE[$_][0] <= $avail) {
458 $busy = 0;
459 my $job = splice @SLOT_QUEUE, $_, 1, ();
460 $job->[2]->send;
461 Coro::cede;
462 goto next_job;
463 } else {
464 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
465 }
466 }
467
468 if (@SLOT_QUEUE) {
469 # we do not use wait_for_tick() as it returns immediately when tick is inactive
470 push @cf::WAIT_FOR_TICK, $signal;
471 $signal->wait;
472 } else {
473 $busy = 0;
474 Coro::schedule;
475 }
305 }; 476 }
306 $TICK_WATCHER->stop; 477};
307 $guard 478
479sub get_slot($;$$) {
480 return if tick_inhibit || $Coro::current == $Coro::main;
481
482 my ($time, $pri, $name) = @_;
483
484 $time = clamp $time, 0.01, $TICK * .6;
485
486 my $sig = new Coro::Signal;
487
488 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
489 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
490 $SLOT_QUEUE->ready;
491 $sig->wait;
308} 492}
309 493
310=item cf::async { BLOCK } 494=item cf::async { BLOCK }
311 495
312Currently the same as Coro::async_pool, meaning you cannot use 496Currently the same as Coro::async_pool, meaning you cannot use
… …
317 501
318BEGIN { *async = \&Coro::async_pool } 502BEGIN { *async = \&Coro::async_pool }
319 503
320=item cf::sync_job { BLOCK } 504=item cf::sync_job { BLOCK }
321 505
322The design of crossfire+ requires that the main coro ($Coro::main) is 506The design of Deliantra requires that the main coroutine ($Coro::main)
323always able to handle events or runnable, as crossfire+ is only partly 507is always able to handle events or runnable, as Deliantra is only
324reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 508partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
509acceptable.
325 510
326If it must be done, put the blocking parts into C<sync_job>. This will run 511If it must be done, put the blocking parts into C<sync_job>. This will run
327the given BLOCK in another coroutine while waiting for the result. The 512the given BLOCK in another coroutine while waiting for the result. The
328server will be frozen during this time, so the block should either finish 513server will be frozen during this time, so the block should either finish
329fast or be very important. 514fast or be very important.
… …
331=cut 516=cut
332 517
333sub sync_job(&) { 518sub sync_job(&) {
334 my ($job) = @_; 519 my ($job) = @_;
335 520
336 if ($Coro::current == $Coro::main) { 521 if (in_main) {
337 my $time = Event::time; 522 my $time = AE::time;
338 523
339 # this is the main coro, too bad, we have to block 524 # this is the main coro, too bad, we have to block
340 # till the operation succeeds, freezing the server :/ 525 # till the operation succeeds, freezing the server :/
341 526
342 # TODO: use suspend/resume instead 527 #LOG llevError, Carp::longmess "sync job";#d#
343 # (but this is cancel-safe) 528
344 my $freeze_guard = freeze_mainloop; 529 my $freeze_guard = freeze_mainloop;
345 530
346 my $busy = 1; 531 my $busy = 1;
347 my @res; 532 my @res;
348 533
349 (async { 534 (async {
535 $Coro::current->desc ("sync job coro");
350 @res = eval { $job->() }; 536 @res = eval { $job->() };
351 warn $@ if $@; 537 error $@ if $@;
352 undef $busy; 538 undef $busy;
353 })->prio (Coro::PRIO_MAX); 539 })->prio (Coro::PRIO_MAX);
354 540
355 while ($busy) { 541 while ($busy) {
356 Coro::cede or Event::one_event; 542 if (Coro::nready) {
543 Coro::cede_notself;
544 } else {
545 EV::loop EV::LOOP_ONESHOT;
357 } 546 }
547 }
358 548
359 $time = Event::time - $time; 549 my $time = AE::time - $time;
360 550
361 LOG llevError | logBacktrace, Carp::longmess "long sync job"
362 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
363
364 $tick_start += $time; # do not account sync jobs to server load 551 $TICK_START += $time; # do not account sync jobs to server load
365 552
366 wantarray ? @res : $res[0] 553 wantarray ? @res : $res[0]
367 } else { 554 } else {
368 # we are in another coroutine, how wonderful, everything just works 555 # we are in another coroutine, how wonderful, everything just works
369 556
… …
389 $EXT_CORO{$coro+0} = $coro; 576 $EXT_CORO{$coro+0} = $coro;
390 577
391 $coro 578 $coro
392} 579}
393 580
394sub write_runtime { 581=item fork_call { }, $args
395 my $runtime = "$LOCALDIR/runtime";
396 582
397 # first touch the runtime file to show we are still running: 583Executes the given code block with the given arguments in a seperate
398 # the fsync below can take a very very long time. 584process, returning the results. Everything must be serialisable with
585Coro::Storable. May, of course, block. Note that the executed sub may
586never block itself or use any form of event handling.
399 587
400 if (my $fh = aio_open $runtime, O_WRONLY, 0) { 588=cut
401 utime undef, undef, $fh; 589
590sub fork_call(&@) {
591 my ($cb, @args) = @_;
592
593 # we seemingly have to make a local copy of the whole thing,
594 # otherwise perl prematurely frees the stuff :/
595 # TODO: investigate and fix (likely this will be rather laborious)
596
597 my @res = Coro::Util::fork_eval {
598 reset_signals;
599 &$cb
600 }, @args;
601
602 wantarray ? @res : $res[-1]
603}
604
605sub objinfo {
606 (
607 "counter value" => cf::object::object_count,
608 "objects created" => cf::object::create_count,
609 "objects destroyed" => cf::object::destroy_count,
610 "freelist size" => cf::object::free_count,
611 "allocated objects" => cf::object::objects_size,
612 "active objects" => cf::object::actives_size,
613 )
614}
615
616=item $coin = coin_from_name $name
617
618=cut
619
620our %coin_alias = (
621 "silver" => "silvercoin",
622 "silvercoin" => "silvercoin",
623 "silvercoins" => "silvercoin",
624 "gold" => "goldcoin",
625 "goldcoin" => "goldcoin",
626 "goldcoins" => "goldcoin",
627 "platinum" => "platinacoin",
628 "platinumcoin" => "platinacoin",
629 "platinumcoins" => "platinacoin",
630 "platina" => "platinacoin",
631 "platinacoin" => "platinacoin",
632 "platinacoins" => "platinacoin",
633 "royalty" => "royalty",
634 "royalties" => "royalty",
635);
636
637sub coin_from_name($) {
638 $coin_alias{$_[0]}
639 ? cf::arch::find $coin_alias{$_[0]}
640 : undef
641}
642
643=item $value = cf::db_get $family => $key
644
645Returns a single value from the environment database.
646
647=item cf::db_put $family => $key => $value
648
649Stores the given C<$value> in the family. It can currently store binary
650data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
651
652=item $db = cf::db_table "name"
653
654Create and/or open a new database table. The string must not be "db" and must be unique
655within each server.
656
657=cut
658
659sub db_table($) {
660 cf::error "db_get called from main context"
661 if $Coro::current == $Coro::main;
662
663 my ($name) = @_;
664 my $db = BDB::db_create $DB_ENV;
665
666 eval {
667 $db->set_flags (BDB::CHKSUM);
668
669 utf8::encode $name;
670 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
671 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
672 cf::cleanup "db_open(db): $!" if $!;
402 } 673 };
674 cf::cleanup "db_open(db): $@" if $@;
403 675
404 my $guard = cf::lock_acquire "write_runtime"; 676 $db
677}
405 678
406 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 679our $DB;
407 or return;
408 680
409 my $value = $cf::RUNTIME + 90 + 10; 681sub db_init {
410 # 10 is the runtime save interval, for a monotonic clock 682 $DB ||= db_table "db";
411 # 60 allows for the watchdog to kill the server. 683}
412 684
413 (aio_write $fh, 0, (length $value), $value, 0) <= 0 685sub db_get($$) {
414 and return; 686 my $key = "$_[0]/$_[1]";
415 687
416 # always fsync - this file is important 688 cf::error "db_get called from main context"
417 aio_fsync $fh 689 if $Coro::current == $Coro::main;
418 and return;
419 690
420 # touch it again to show we are up-to-date 691 BDB::db_get $DB, undef, $key, my $data;
421 utime undef, undef, $fh;
422 692
423 close $fh 693 $! ? ()
424 or return; 694 : $data
695}
425 696
426 aio_rename "$runtime~", $runtime 697sub db_put($$$) {
427 and return; 698 BDB::dbreq_pri 4;
699 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
700}
428 701
429 warn "runtime file written.\n";#d# 702=item cf::cache $id => [$paths...], $processversion => $process
430 703
704Generic caching function that returns the value of the resource $id,
705caching and regenerating as required.
706
707This function can block.
708
709=cut
710
711sub cache {
712 my ($id, $src, $processversion, $process) = @_;
713
714 my $meta =
715 join "\x00",
716 $processversion,
717 map {
718 aio_stat $_
719 and Carp::croak "$_: $!";
720
721 ($_, (stat _)[7,9])
722 } @$src;
723
724 my $dbmeta = db_get cache => "$id/meta";
725 if ($dbmeta ne $meta) {
726 # changed, we may need to process
727
728 my @data;
729 my $md5;
730
731 for (0 .. $#$src) {
732 0 <= aio_load $src->[$_], $data[$_]
733 or Carp::croak "$src->[$_]: $!";
734 }
735
736 # if processing is expensive, check
737 # checksum first
738 if (1) {
739 $md5 =
740 join "\x00",
741 $processversion,
742 map {
743 cf::cede_to_tick;
744 ($src->[$_], Digest::MD5::md5_hex $data[$_])
745 } 0.. $#$src;
746
747
748 my $dbmd5 = db_get cache => "$id/md5";
749 if ($dbmd5 eq $md5) {
750 db_put cache => "$id/meta", $meta;
751
752 return db_get cache => "$id/data";
753 }
754 }
755
756 my $t1 = Time::HiRes::time;
757 my $data = $process->(\@data);
758 my $t2 = Time::HiRes::time;
759
760 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
761
762 db_put cache => "$id/data", $data;
763 db_put cache => "$id/md5" , $md5;
764 db_put cache => "$id/meta", $meta;
765
766 return $data;
431 1 767 }
768
769 db_get cache => "$id/data"
432} 770}
433 771
434=item cf::datalog type => key => value, ... 772=item cf::datalog type => key => value, ...
435 773
436Log a datalog packet of the given type with the given key-value pairs. 774Log a datalog packet of the given type with the given key-value pairs.
437 775
438=cut 776=cut
439 777
440sub datalog($@) { 778sub datalog($@) {
441 my ($type, %kv) = @_; 779 my ($type, %kv) = @_;
442 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 780 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
443} 781}
444 782
445=back 783=back
446 784
447=cut 785=cut
448 786
449############################################################################# 787#############################################################################
450 788
451=head2 ATTACHABLE OBJECTS 789=head2 ATTACHABLE OBJECTS
452 790
453Many objects in crossfire are so-called attachable objects. That means you can 791Many objects in deliantra are so-called attachable objects. That means you can
454attach callbacks/event handlers (a collection of which is called an "attachment") 792attach callbacks/event handlers (a collection of which is called an "attachment")
455to it. All such attachable objects support the following methods. 793to it. All such attachable objects support the following methods.
456 794
457In the following description, CLASS can be any of C<global>, C<object> 795In the following description, CLASS can be any of C<global>, C<object>
458C<player>, C<client> or C<map> (i.e. the attachable objects in 796C<player>, C<client> or C<map> (i.e. the attachable objects in
459crossfire+). 797Deliantra).
460 798
461=over 4 799=over 4
462 800
463=item $attachable->attach ($attachment, key => $value...) 801=item $attachable->attach ($attachment, key => $value...)
464 802
… …
508=item cf::CLASS::attachment $name, ... 846=item cf::CLASS::attachment $name, ...
509 847
510Register an attachment by C<$name> through which attachable objects of the 848Register an attachment by C<$name> through which attachable objects of the
511given CLASS can refer to this attachment. 849given CLASS can refer to this attachment.
512 850
513Some classes such as crossfire maps and objects can specify attachments 851Some classes such as deliantra maps and objects can specify attachments
514that are attached at load/instantiate time, thus the need for a name. 852that are attached at load/instantiate time, thus the need for a name.
515 853
516These calls expect any number of the following handler/hook descriptions: 854These calls expect any number of the following handler/hook descriptions:
517 855
518=over 4 856=over 4
… …
642 980
643 } elsif (exists $cb_id{$type}) { 981 } elsif (exists $cb_id{$type}) {
644 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 982 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
645 983
646 } elsif (ref $type) { 984 } elsif (ref $type) {
647 warn "attaching objects not supported, ignoring.\n"; 985 error "attaching objects not supported, ignoring.\n";
648 986
649 } else { 987 } else {
650 shift @arg; 988 shift @arg;
651 warn "attach argument '$type' not supported, ignoring.\n"; 989 error "attach argument '$type' not supported, ignoring.\n";
652 } 990 }
653 } 991 }
654} 992}
655 993
656sub _object_attach { 994sub _object_attach {
… …
666 _attach $registry, $klass, @attach; 1004 _attach $registry, $klass, @attach;
667 } 1005 }
668 1006
669 $obj->{$name} = \%arg; 1007 $obj->{$name} = \%arg;
670 } else { 1008 } else {
671 warn "object uses attachment '$name' that is not available, postponing.\n"; 1009 info "object uses attachment '$name' which is not available, postponing.\n";
672 } 1010 }
673 1011
674 $obj->{_attachment}{$name} = undef; 1012 $obj->{_attachment}{$name} = undef;
675} 1013}
676 1014
… …
716 "; 1054 ";
717 die if $@; 1055 die if $@;
718} 1056}
719 1057
720our $override; 1058our $override;
721our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 1059our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
722 1060
723sub override { 1061sub override {
724 $override = 1; 1062 $override = 1;
725 @invoke_results = (); 1063 @INVOKE_RESULTS = (@_);
726} 1064}
727 1065
728sub do_invoke { 1066sub do_invoke {
729 my $event = shift; 1067 my $event = shift;
730 my $callbacks = shift; 1068 my $callbacks = shift;
731 1069
732 @invoke_results = (); 1070 @INVOKE_RESULTS = ();
733 1071
734 local $override; 1072 local $override;
735 1073
736 for (@$callbacks) { 1074 for (@$callbacks) {
737 eval { &{$_->[1]} }; 1075 eval { &{$_->[1]} };
738 1076
739 if ($@) { 1077 if ($@) {
740 warn "$@";
741 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1078 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
742 override; 1079 override;
743 } 1080 }
744 1081
745 return 1 if $override; 1082 return 1 if $override;
746 } 1083 }
747 1084
748 0 1085 0
749} 1086}
750 1087
751=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1088=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
752 1089
753=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1090=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
754 1091
755Generate an object-specific event with the given arguments. 1092Generate an object-specific event with the given arguments.
756 1093
757This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1094This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
758removed in future versions), and there is no public API to access override 1095removed in future versions), and there is no public API to access override
759results (if you must, access C<@cf::invoke_results> directly). 1096results (if you must, access C<@cf::INVOKE_RESULTS> directly).
760 1097
761=back 1098=back
762 1099
763=cut 1100=cut
764 1101
765############################################################################# 1102#############################################################################
766# object support 1103# object support
1104
1105sub _object_equal($$);
1106sub _object_equal($$) {
1107 my ($a, $b) = @_;
1108
1109 return 0 unless (ref $a) eq (ref $b);
1110
1111 if ("HASH" eq ref $a) {
1112 my @ka = keys %$a;
1113 my @kb = keys %$b;
1114
1115 return 0 if @ka != @kb;
1116
1117 for (0 .. $#ka) {
1118 return 0 unless $ka[$_] eq $kb[$_];
1119 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1120 }
1121
1122 } elsif ("ARRAY" eq ref $a) {
1123
1124 return 0 if @$a != @$b;
1125
1126 for (0 .. $#$a) {
1127 return 0 unless _object_equal $a->[$_], $b->[$_];
1128 }
1129
1130 } elsif ($a ne $b) {
1131 return 0;
1132 }
1133
1134 1
1135}
1136
1137our $SLOW_MERGES;#d#
1138sub _can_merge {
1139 my ($ob1, $ob2) = @_;
1140
1141 ++$SLOW_MERGES;#d#
1142
1143 # we do the slow way here
1144 return _object_equal $ob1, $ob2
1145}
767 1146
768sub reattach { 1147sub reattach {
769 # basically do the same as instantiate, without calling instantiate 1148 # basically do the same as instantiate, without calling instantiate
770 my ($obj) = @_; 1149 my ($obj) = @_;
771 1150
1151 # no longer needed after getting rid of delete_package?
772 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1152 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
773 1153
774 my $registry = $obj->registry; 1154 my $registry = $obj->registry;
775 1155
776 @$registry = (); 1156 @$registry = ();
777 1157
… …
782 for (@$attach) { 1162 for (@$attach) {
783 my ($klass, @attach) = @$_; 1163 my ($klass, @attach) = @$_;
784 _attach $registry, $klass, @attach; 1164 _attach $registry, $klass, @attach;
785 } 1165 }
786 } else { 1166 } else {
787 warn "object uses attachment '$name' that is not available, postponing.\n"; 1167 info "object uses attachment '$name' that is not available, postponing.\n";
788 } 1168 }
789 } 1169 }
790} 1170}
791 1171
792cf::attachable->attach ( 1172cf::attachable->attach (
793 prio => -1000000, 1173 prio => -1000000,
794 on_instantiate => sub { 1174 on_instantiate => sub {
795 my ($obj, $data) = @_; 1175 my ($obj, $data) = @_;
796 1176
797 $data = from_json $data; 1177 $data = decode_json $data;
798 1178
799 for (@$data) { 1179 for (@$data) {
800 my ($name, $args) = @$_; 1180 my ($name, $args) = @$_;
801 1181
802 $obj->attach ($name, %{$args || {} }); 1182 $obj->attach ($name, %{$args || {} });
… …
818sub object_freezer_save { 1198sub object_freezer_save {
819 my ($filename, $rdata, $objs) = @_; 1199 my ($filename, $rdata, $objs) = @_;
820 1200
821 sync_job { 1201 sync_job {
822 if (length $$rdata) { 1202 if (length $$rdata) {
1203 utf8::decode (my $decname = $filename);
823 warn sprintf "saving %s (%d,%d)\n", 1204 trace sprintf "saving %s (%d,%d)\n",
824 $filename, length $$rdata, scalar @$objs; 1205 $decname, length $$rdata, scalar @$objs
1206 if $VERBOSE_IO;
825 1207
826 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1208 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
827 chmod SAVE_MODE, $fh; 1209 aio_chmod $fh, SAVE_MODE;
828 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1210 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
829 aio_fsync $fh if $cf::USE_FSYNC; 1211 if ($cf::USE_FSYNC) {
1212 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1213 aio_fsync $fh;
1214 }
830 close $fh; 1215 aio_close $fh;
831 1216
832 if (@$objs) { 1217 if (@$objs) {
833 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1218 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
834 chmod SAVE_MODE, $fh; 1219 aio_chmod $fh, SAVE_MODE;
835 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1220 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
836 aio_write $fh, 0, (length $data), $data, 0; 1221 aio_write $fh, 0, (length $data), $data, 0;
837 aio_fsync $fh if $cf::USE_FSYNC; 1222 if ($cf::USE_FSYNC) {
1223 aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE | IO::AIO::SYNC_FILE_RANGE_WRITE | IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
1224 aio_fsync $fh;
1225 }
838 close $fh; 1226 aio_close $fh;
839 aio_rename "$filename.pst~", "$filename.pst"; 1227 aio_rename "$filename.pst~", "$filename.pst";
840 } 1228 }
841 } else { 1229 } else {
842 aio_unlink "$filename.pst"; 1230 aio_unlink "$filename.pst";
843 } 1231 }
844 1232
845 aio_rename "$filename~", $filename; 1233 aio_rename "$filename~", $filename;
1234
1235 $filename =~ s%/[^/]+$%%;
1236 aio_pathsync $filename if $cf::USE_FSYNC;
846 } else { 1237 } else {
847 warn "FATAL: $filename~: $!\n"; 1238 error "unable to save objects: $filename~: $!\n";
848 } 1239 }
849 } else { 1240 } else {
850 aio_unlink $filename; 1241 aio_unlink $filename;
851 aio_unlink "$filename.pst"; 1242 aio_unlink "$filename.pst";
852 } 1243 }
853 } 1244 };
854} 1245}
855 1246
856sub object_freezer_as_string { 1247sub object_freezer_as_string {
857 my ($rdata, $objs) = @_; 1248 my ($rdata, $objs) = @_;
858 1249
… …
870 or return; 1261 or return;
871 1262
872 unless (aio_stat "$filename.pst") { 1263 unless (aio_stat "$filename.pst") {
873 (aio_load "$filename.pst", $av) >= 0 1264 (aio_load "$filename.pst", $av) >= 0
874 or return; 1265 or return;
1266
875 $av = eval { (Storable::thaw $av)->{objs} }; 1267 my $st = eval { Coro::Storable::thaw $av };
1268 $av = $st->{objs};
876 } 1269 }
877 1270
1271 utf8::decode (my $decname = $filename);
878 warn sprintf "loading %s (%d)\n", 1272 trace sprintf "loading %s (%d,%d)\n",
879 $filename, length $data, scalar @{$av || []};#d# 1273 $decname, length $data, scalar @{$av || []}
1274 if $VERBOSE_IO;
1275
880 return ($data, $av); 1276 ($data, $av)
881} 1277}
1278
1279=head2 COMMAND CALLBACKS
1280
1281=over 4
1282
1283=cut
882 1284
883############################################################################# 1285#############################################################################
884# command handling &c 1286# command handling &c
885 1287
886=item cf::register_command $name => \&callback($ob,$args); 1288=item cf::register_command $name => \&callback($ob,$args);
… …
899 push @{ $COMMAND{$name} }, [$caller, $cb]; 1301 push @{ $COMMAND{$name} }, [$caller, $cb];
900} 1302}
901 1303
902=item cf::register_extcmd $name => \&callback($pl,$packet); 1304=item cf::register_extcmd $name => \&callback($pl,$packet);
903 1305
904Register a callbackf ro execution when the client sends an extcmd packet. 1306Register a callback for execution when the client sends an (synchronous)
1307extcmd packet. Ext commands will be processed in the order they are
1308received by the server, like other user commands. The first argument is
1309the logged-in player. Ext commands can only be processed after a player
1310has logged in successfully.
905 1311
906If the callback returns something, it is sent back as if reply was being 1312If the callback returns something, it is sent back as if reply was being
907called. 1313called.
908 1314
1315=item cf::register_exticmd $name => \&callback($ns,$packet);
1316
1317Register a callback for execution when the client sends an (asynchronous)
1318exticmd packet. Exti commands are processed by the server as soon as they
1319are received, i.e. out of order w.r.t. other commands. The first argument
1320is a client socket. Exti commands can be received anytime, even before
1321log-in.
1322
1323If the callback returns something, it is sent back as if reply was being
1324called.
1325
909=cut 1326=cut
910 1327
911sub register_extcmd { 1328sub register_extcmd {
912 my ($name, $cb) = @_; 1329 my ($name, $cb) = @_;
913 1330
914 $EXTCMD{$name} = $cb; 1331 $EXTCMD{$name} = $cb;
915} 1332}
916 1333
1334sub register_exticmd {
1335 my ($name, $cb) = @_;
1336
1337 $EXTICMD{$name} = $cb;
1338}
1339
1340use File::Glob ();
1341
917cf::player->attach ( 1342cf::player->attach (
918 on_command => sub { 1343 on_unknown_command => sub {
919 my ($pl, $name, $params) = @_; 1344 my ($pl, $name, $params) = @_;
920 1345
921 my $cb = $COMMAND{$name} 1346 my $cb = $COMMAND{$name}
922 or return; 1347 or return;
923 1348
… …
928 cf::override; 1353 cf::override;
929 }, 1354 },
930 on_extcmd => sub { 1355 on_extcmd => sub {
931 my ($pl, $buf) = @_; 1356 my ($pl, $buf) = @_;
932 1357
933 my $msg = eval { from_json $buf }; 1358 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
934 1359
935 if (ref $msg) { 1360 if (ref $msg) {
1361 my ($type, $reply, @payload) =
1362 "ARRAY" eq ref $msg
1363 ? @$msg
1364 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1365
1366 my @reply;
1367
936 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1368 if (my $cb = $EXTCMD{$type}) {
937 if (my %reply = $cb->($pl, $msg)) { 1369 @reply = $cb->($pl, @payload);
938 $pl->ext_reply ($msg->{msgid}, %reply);
939 }
940 } 1370 }
1371
1372 $pl->ext_reply ($reply, @reply)
1373 if $reply;
1374
941 } else { 1375 } else {
942 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1376 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
943 } 1377 }
944 1378
945 cf::override; 1379 cf::override;
946 }, 1380 },
947); 1381);
948 1382
1383# "readahead" all extensions
949sub load_extension { 1384sub cache_extensions {
950 my ($path) = @_; 1385 my $grp = IO::AIO::aio_group;
951 1386
952 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1387 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
953 my $base = $1; 1388 for (grep /\.ext$/, @{$_[0]}) {
954 my $pkg = $1; 1389 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
955 $pkg =~ s/[^[:word:]]/_/g;
956 $pkg = "ext::$pkg";
957
958 warn "... loading '$path' into '$pkg'\n";
959
960 open my $fh, "<:utf8", $path
961 or die "$path: $!";
962
963 my $source =
964 "package $pkg; use strict; use utf8;\n"
965 . "#line 1 \"$path\"\n{\n"
966 . (do { local $/; <$fh> })
967 . "\n};\n1";
968
969 unless (eval $source) {
970 my $msg = $@ ? "$path: $@\n"
971 : "extension disabled.\n";
972 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
973 warn $@;
974 warn "mandatory extension failed to load, exiting.\n";
975 exit 1;
976 } 1390 }
977 die $@;
978 } 1391 };
979 1392
980 push @EXTS, $pkg; 1393 $grp
981} 1394}
982 1395
983sub load_extensions { 1396sub load_extensions {
1397 info "loading extensions...";
1398
1399 cf::sync_job {
1400 my %todo;
1401
984 for my $ext (<$LIBDIR/*.ext>) { 1402 for my $path (<$LIBDIR/*.ext>) {
985 next unless -r $ext; 1403 next unless -r $path;
986 eval { 1404
987 load_extension $ext; 1405 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1406 my $base = $1;
1407 my $pkg = $1;
1408 $pkg =~ s/[^[:word:]]/_/g;
1409 $pkg = "ext::$pkg";
1410
1411 open my $fh, "<:utf8", $path
1412 or die "$path: $!";
1413
1414 my $source = do { local $/; <$fh> };
1415
1416 my %ext = (
1417 path => $path,
1418 base => $base,
1419 pkg => $pkg,
1420 );
1421
1422 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1423 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1424
1425 $ext{source} =
1426 "package $pkg; use common::sense;\n"
1427 . "#line 1 \"$path\"\n{\n"
1428 . $source
1429 . "\n};\n1";
1430
1431 $todo{$base} = \%ext;
1432 }
1433
1434 my $pass = 0;
1435 my %done;
1436 while (%todo) {
1437 my $progress;
1438
1439 ++$pass;
1440
1441 ext:
1442 while (my ($k, $v) = each %todo) {
1443 for (split /,\s*/, $v->{meta}{depends}) {
1444 next ext
1445 unless exists $done{$_};
1446 }
1447
1448 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1449
1450 my $active = eval $v->{source};
1451
1452 if (length $@) {
1453 error "$v->{path}: $@\n";
1454 undef $@; # work around perl 5.10.0 utf-8 caching bug
1455
1456 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1457 if exists $v->{meta}{mandatory};
1458
1459 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1460 delete $todo{$k};
1461 } else {
1462 $done{$k} = delete $todo{$k};
1463 push @EXTS, $v->{pkg};
1464 $progress = 1;
1465
1466 info "$v->{base}: extension inactive.\n"
1467 unless $active;
1468 }
988 1 1469 }
989 } or warn "$ext not loaded: $@"; 1470
1471 unless ($progress) {
1472 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1473
1474 while (my ($k, $v) = each %todo) {
1475 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1476 if exists $v->{meta}{mandatory};
1477 }
1478 }
1479 }
990 } 1480 };
991} 1481}
992 1482
993############################################################################# 1483#############################################################################
994 1484
1485=back
1486
995=head2 CORE EXTENSIONS 1487=head2 CORE EXTENSIONS
996 1488
997Functions and methods that extend core crossfire objects. 1489Functions and methods that extend core deliantra objects.
998 1490
999=cut 1491=cut
1000 1492
1001package cf::player; 1493package cf::player;
1002 1494
1003use Coro::AIO; 1495use Coro::AIO;
1004 1496
1005=head3 cf::player 1497=head3 cf::player
1006 1498
1007=over 4 1499=over 4
1500
1501=item cf::player::num_playing
1502
1503Returns the official number of playing players, as per the Crossfire metaserver rules.
1504
1505=cut
1506
1507sub num_playing {
1508 scalar grep
1509 $_->ob->map
1510 && !$_->hidden
1511 && !$_->ob->flag (cf::FLAG_WIZ),
1512 cf::player::list
1513}
1008 1514
1009=item cf::player::find $login 1515=item cf::player::find $login
1010 1516
1011Returns the given player object, loading it if necessary (might block). 1517Returns the given player object, loading it if necessary (might block).
1012 1518
… …
1031 1537
1032sub exists($) { 1538sub exists($) {
1033 my ($login) = @_; 1539 my ($login) = @_;
1034 1540
1035 $cf::PLAYER{$login} 1541 $cf::PLAYER{$login}
1036 or cf::sync_job { !aio_stat path $login } 1542 or !aio_stat path $login
1037} 1543}
1038 1544
1039sub find($) { 1545sub find($) {
1040 return $cf::PLAYER{$_[0]} || do { 1546 return $cf::PLAYER{$_[0]} || do {
1041 my $login = $_[0]; 1547 my $login = $_[0];
… …
1048 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1554 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1049 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1555 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1050 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1556 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1051 aio_unlink +(playerdir $login) . "/$login.pl"; 1557 aio_unlink +(playerdir $login) . "/$login.pl";
1052 1558
1053 my $pl = load_pl path $login 1559 my $f = new_from_file cf::object::thawer path $login
1054 or return; 1560 or return;
1561
1562 my $pl = cf::player::load_pl $f
1563 or return;
1564
1565 local $cf::PLAYER_LOADING{$login} = $pl;
1566 $f->resolve_delayed_derefs;
1055 $cf::PLAYER{$login} = $pl 1567 $cf::PLAYER{$login} = $pl
1056 } 1568 }
1057 } 1569 }
1058} 1570}
1571
1572cf::player->attach (
1573 on_load => sub {
1574 my ($pl, $path) = @_;
1575
1576 # restore slots saved in save, below
1577 my $slots = delete $pl->{_slots};
1578
1579 $pl->ob->current_weapon ($slots->[0]);
1580 $pl->combat_ob ($slots->[1]);
1581 $pl->ranged_ob ($slots->[2]);
1582 },
1583);
1059 1584
1060sub save($) { 1585sub save($) {
1061 my ($pl) = @_; 1586 my ($pl) = @_;
1062 1587
1063 return if $pl->{deny_save}; 1588 return if $pl->{deny_save};
… …
1068 return if $pl->{deny_save}; 1593 return if $pl->{deny_save};
1069 1594
1070 aio_mkdir playerdir $pl, 0770; 1595 aio_mkdir playerdir $pl, 0770;
1071 $pl->{last_save} = $cf::RUNTIME; 1596 $pl->{last_save} = $cf::RUNTIME;
1072 1597
1598 cf::get_slot 0.01;
1599
1600 # save slots, to be restored later
1601 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1602
1073 $pl->save_pl ($path); 1603 $pl->save_pl ($path);
1074 Coro::cede; 1604 cf::cede_to_tick;
1075} 1605}
1076 1606
1077sub new($) { 1607sub new($) {
1078 my ($login) = @_; 1608 my ($login) = @_;
1079 1609
… …
1085 $cf::PLAYER{$login} = $self; 1615 $cf::PLAYER{$login} = $self;
1086 1616
1087 $self 1617 $self
1088} 1618}
1089 1619
1620=item $player->send_msg ($channel, $msg, $color, [extra...])
1621
1622=cut
1623
1624sub send_msg {
1625 my $ns = shift->ns
1626 or return;
1627 $ns->send_msg (@_);
1628}
1629
1090=item $pl->quit_character 1630=item $pl->quit_character
1091 1631
1092Nukes the player without looking back. If logged in, the connection will 1632Nukes the player without looking back. If logged in, the connection will
1093be destroyed. May block for a long time. 1633be destroyed. May block for a long time.
1094 1634
… …
1098 my ($pl) = @_; 1638 my ($pl) = @_;
1099 1639
1100 my $name = $pl->ob->name; 1640 my $name = $pl->ob->name;
1101 1641
1102 $pl->{deny_save} = 1; 1642 $pl->{deny_save} = 1;
1103 $pl->password ("*"); # this should lock out the player until we nuked the dir 1643 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1104 1644
1105 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1645 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1106 $pl->deactivate; 1646 $pl->deactivate;
1647 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1107 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1648 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1108 $pl->ns->destroy if $pl->ns; 1649 $pl->ns->destroy if $pl->ns;
1109 1650
1110 my $path = playerdir $pl; 1651 my $path = playerdir $pl;
1111 my $temp = "$path~$cf::RUNTIME~deleting~"; 1652 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1147 or return []; 1688 or return [];
1148 1689
1149 my @logins; 1690 my @logins;
1150 1691
1151 for my $login (@$dirs) { 1692 for my $login (@$dirs) {
1693 my $path = path $login;
1694
1695 # a .pst is a dead give-away for a valid player
1696 # if no pst file found, open and chekc for blocked users
1697 if (aio_stat "$path.pst") {
1152 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1698 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1153 aio_read $fh, 0, 512, my $buf, 0 or next; 1699 aio_read $fh, 0, 512, my $buf, 0 or next;
1154 $buf !~ /^password -------------$/m or next; # official not-valid tag 1700 $buf !~ /^password -------------$/m or next; # official not-valid tag
1701 }
1155 1702
1156 utf8::decode $login; 1703 utf8::decode $login;
1157 push @logins, $login; 1704 push @logins, $login;
1158 } 1705 }
1159 1706
1160 \@logins 1707 \@logins
1161} 1708}
1162 1709
1163=item $player->maps 1710=item $player->maps
1711
1712=item cf::player::maps $login
1164 1713
1165Returns an arrayref of map paths that are private for this 1714Returns an arrayref of map paths that are private for this
1166player. May block. 1715player. May block.
1167 1716
1168=cut 1717=cut
… …
1186 } 1735 }
1187 1736
1188 \@paths 1737 \@paths
1189} 1738}
1190 1739
1740=item $protocol_xml = $player->expand_cfpod ($cfpod)
1741
1742Expand deliantra pod fragments into protocol xml.
1743
1191=item $player->ext_reply ($msgid, %msg) 1744=item $player->ext_reply ($msgid, @msg)
1192 1745
1193Sends an ext reply to the player. 1746Sends an ext reply to the player.
1194 1747
1195=cut 1748=cut
1196 1749
1197sub ext_reply($$%) { 1750sub ext_reply($$@) {
1198 my ($self, $id, %msg) = @_; 1751 my ($self, $id, @msg) = @_;
1199 1752
1200 $msg{msgid} = $id; 1753 $self->ns->ext_reply ($id, @msg)
1201
1202 $self->send ("ext " . cf::to_json \%msg);
1203} 1754}
1204 1755
1205=item $player->ext_event ($type, %msg) 1756=item $player->ext_msg ($type, @msg)
1206 1757
1207Sends an ext event to the client. 1758Sends an ext event to the client.
1208 1759
1209=cut 1760=cut
1210 1761
1211sub ext_event($$%) { 1762sub ext_msg($$@) {
1212 my ($self, $type, %msg) = @_; 1763 my ($self, $type, @msg) = @_;
1213 1764
1214 $self->ns->ext_event ($type, %msg); 1765 $self->ns->ext_msg ($type, @msg);
1215} 1766}
1216 1767
1217=head3 cf::region 1768=head3 cf::region
1218 1769
1219=over 4 1770=over 4
… …
1222 1773
1223package cf::region; 1774package cf::region;
1224 1775
1225=item cf::region::find_by_path $path 1776=item cf::region::find_by_path $path
1226 1777
1227Tries to decuce the probable region for a map knowing only its path. 1778Tries to decuce the likely region for a map knowing only its path.
1228 1779
1229=cut 1780=cut
1230 1781
1231sub find_by_path($) { 1782sub find_by_path($) {
1232 my ($path) = @_; 1783 my ($path) = @_;
1233 1784
1785 $path =~ s/^~[^\/]*//; # skip ~login
1786
1234 my ($match, $specificity); 1787 my ($match, $specificity);
1235 1788
1236 for my $region (list) { 1789 for my $region (list) {
1237 if ($region->match && $path =~ $region->match) { 1790 if ($region->{match} && $path =~ $region->{match}) {
1238 ($match, $specificity) = ($region, $region->specificity) 1791 ($match, $specificity) = ($region, $region->specificity)
1239 if $region->specificity > $specificity; 1792 if $region->specificity > $specificity;
1240 } 1793 }
1241 } 1794 }
1242 1795
… …
1263our $MAX_RESET = 3600; 1816our $MAX_RESET = 3600;
1264our $DEFAULT_RESET = 3000; 1817our $DEFAULT_RESET = 3000;
1265 1818
1266sub generate_random_map { 1819sub generate_random_map {
1267 my ($self, $rmp) = @_; 1820 my ($self, $rmp) = @_;
1821
1822 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1823
1268 # mit "rum" bekleckern, nicht 1824 # mit "rum" bekleckern, nicht
1269 $self->_create_random_map ( 1825 $self->_create_random_map (
1270 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1826 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1271 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1827 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1272 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1828 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1273 $rmp->{exit_on_final_map}, 1829 $rmp->{exit_on_final_map},
1274 $rmp->{xsize}, $rmp->{ysize}, 1830 $rmp->{xsize}, $rmp->{ysize},
1275 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1831 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1276 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1832 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1291 1847
1292sub register { 1848sub register {
1293 my (undef, $regex, $prio) = @_; 1849 my (undef, $regex, $prio) = @_;
1294 my $pkg = caller; 1850 my $pkg = caller;
1295 1851
1296 no strict;
1297 push @{"$pkg\::ISA"}, __PACKAGE__; 1852 push @{"$pkg\::ISA"}, __PACKAGE__;
1298 1853
1299 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1854 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1300} 1855}
1301 1856
1302# also paths starting with '/' 1857# also paths starting with '/'
1303$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1858$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1304 1859
1305sub thawer_merge { 1860sub thawer_merge {
1306 my ($self, $merge) = @_; 1861 my ($self, $merge) = @_;
1307 1862
1308 # we have to keep some variables in memory intact 1863 # we have to keep some variables in memory intact
1309 local $self->{path}; 1864 local $self->{path};
1310 local $self->{load_path}; 1865 local $self->{load_path};
1311 local $self->{deny_save};
1312 local $self->{deny_reset};
1313 1866
1314 $self->SUPER::thawer_merge ($merge); 1867 $self->SUPER::thawer_merge ($merge);
1315} 1868}
1316 1869
1317sub normalise { 1870sub normalise {
… …
1364 $self->init; # pass $1 etc. 1917 $self->init; # pass $1 etc.
1365 return $self; 1918 return $self;
1366 } 1919 }
1367 } 1920 }
1368 1921
1369 Carp::carp "unable to resolve path '$path' (base '$base')."; 1922 Carp::cluck "unable to resolve path '$path' (base '$base').";
1370 () 1923 ()
1371} 1924}
1372 1925
1373sub init { 1926sub init {
1374 my ($self) = @_; 1927 my ($self) = @_;
… …
1396 1949
1397# the temporary/swap location 1950# the temporary/swap location
1398sub save_path { 1951sub save_path {
1399 my ($self) = @_; 1952 my ($self) = @_;
1400 1953
1401 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1954 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1402 "$TMPDIR/$path.map" 1955 "$TMPDIR/$path.map"
1403} 1956}
1404 1957
1405# the unique path, undef == no special unique path 1958# the unique path, undef == no special unique path
1406sub uniq_path { 1959sub uniq_path {
1407 my ($self) = @_; 1960 my ($self) = @_;
1408 1961
1409 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1962 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1410 "$UNIQUEDIR/$path" 1963 "$UNIQUEDIR/$path"
1411} 1964}
1412 1965
1413# and all this just because we cannot iterate over 1966sub decay_objects {
1414# all maps in C++...
1415sub change_all_map_light {
1416 my ($change) = @_; 1967 my ($self) = @_;
1417 1968
1418 $_->change_map_light ($change) 1969 return if $self->{deny_reset};
1419 for grep $_->outdoor, values %cf::MAP; 1970
1971 $self->do_decay_objects;
1420} 1972}
1421 1973
1422sub unlink_save { 1974sub unlink_save {
1423 my ($self) = @_; 1975 my ($self) = @_;
1424 1976
… …
1429 1981
1430sub load_header_from($) { 1982sub load_header_from($) {
1431 my ($self, $path) = @_; 1983 my ($self, $path) = @_;
1432 1984
1433 utf8::encode $path; 1985 utf8::encode $path;
1434 #aio_open $path, O_RDONLY, 0 1986 my $f = new_from_file cf::object::thawer $path
1435 # or return;
1436
1437 $self->_load_header ($path)
1438 or return; 1987 or return;
1988
1989 $self->_load_header ($f)
1990 or return;
1991
1992 local $MAP_LOADING{$self->{path}} = $self;
1993 $f->resolve_delayed_derefs;
1439 1994
1440 $self->{load_path} = $path; 1995 $self->{load_path} = $path;
1441 1996
1442 1 1997 1
1443} 1998}
… …
1482 $self->load_header_orig 2037 $self->load_header_orig
1483 or return; 2038 or return;
1484 $self->prepare_orig; 2039 $self->prepare_orig;
1485 } 2040 }
1486 2041
2042 $self->{deny_reset} = 1
2043 if $self->no_reset;
2044
1487 $self->default_region (cf::region::find_by_path $self->{path}) 2045 $self->default_region (cf::region::find_by_path $self->{path})
1488 unless $self->default_region; 2046 unless $self->default_region;
1489 2047
1490 1 2048 1
1491} 2049}
… …
1494sub find { 2052sub find {
1495 my ($path, $origin) = @_; 2053 my ($path, $origin) = @_;
1496 2054
1497 $path = normalise $path, $origin && $origin->path; 2055 $path = normalise $path, $origin && $origin->path;
1498 2056
2057 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1499 cf::lock_wait "map_find:$path"; 2058 my $guard2 = cf::lock_acquire "map_find:$path";
1500 2059
1501 $cf::MAP{$path} || do { 2060 $cf::MAP{$path} || do {
1502 my $guard = cf::lock_acquire "map_find:$path";
1503 my $map = new_from_path cf::map $path 2061 my $map = new_from_path cf::map $path
1504 or return; 2062 or return;
1505 2063
1506 $map->{last_save} = $cf::RUNTIME; 2064 $map->{last_save} = $cf::RUNTIME;
1507 2065
1508 $map->load_header 2066 $map->load_header
1509 or return; 2067 or return;
1510 2068
1511 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 2069 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1512 # doing this can freeze the server in a sync job, obviously 2070 # doing this can freeze the server in a sync job, obviously
1513 #$cf::WAIT_FOR_TICK->wait; 2071 #$cf::WAIT_FOR_TICK->wait;
2072 undef $guard2;
2073 undef $guard1;
1514 $map->reset; 2074 $map->reset;
1515 undef $guard;
1516 return find $path; 2075 return find $path;
1517 } 2076 }
1518 2077
1519 $cf::MAP{$path} = $map 2078 $cf::MAP{$path} = $map
1520 } 2079 }
1521} 2080}
1522 2081
1523sub pre_load { } 2082sub pre_load { }
1524sub post_load { } 2083#sub post_load { } # XS
1525 2084
1526sub load { 2085sub load {
1527 my ($self) = @_; 2086 my ($self) = @_;
1528 2087
1529 local $self->{deny_reset} = 1; # loading can take a long time 2088 local $self->{deny_reset} = 1; # loading can take a long time
1530 2089
1531 my $path = $self->{path}; 2090 my $path = $self->{path};
1532 2091
1533 { 2092 {
1534 my $guard = cf::lock_acquire "map_load:$path"; 2093 my $guard = cf::lock_acquire "map_data:$path";
1535 2094
2095 return unless $self->valid;
1536 return if $self->in_memory != cf::MAP_SWAPPED; 2096 return unless $self->in_memory == cf::MAP_SWAPPED;
1537 2097
1538 $self->in_memory (cf::MAP_LOADING); 2098 $self->in_memory (cf::MAP_LOADING);
1539 2099
1540 $self->alloc; 2100 $self->alloc;
1541 2101
1542 $self->pre_load; 2102 $self->pre_load;
1543 Coro::cede; 2103 cf::cede_to_tick;
1544 2104
2105 my $f = new_from_file cf::object::thawer $self->{load_path};
2106 $f->skip_block;
1545 $self->_load_objects ($self->{load_path}, 1) 2107 $self->_load_objects ($f)
1546 or return; 2108 or return;
1547 2109
1548 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2110 $self->post_load_original
1549 if delete $self->{load_original}; 2111 if delete $self->{load_original};
1550 2112
1551 if (my $uniq = $self->uniq_path) { 2113 if (my $uniq = $self->uniq_path) {
1552 utf8::encode $uniq; 2114 utf8::encode $uniq;
1553 if (aio_open $uniq, O_RDONLY, 0) { 2115 unless (aio_stat $uniq) {
2116 if (my $f = new_from_file cf::object::thawer $uniq) {
1554 $self->clear_unique_items; 2117 $self->clear_unique_items;
1555 $self->_load_objects ($uniq, 0); 2118 $self->_load_objects ($f);
2119 $f->resolve_delayed_derefs;
2120 }
1556 } 2121 }
1557 } 2122 }
1558 2123
1559 Coro::cede; 2124 $f->resolve_delayed_derefs;
2125
2126 cf::cede_to_tick;
1560 # now do the right thing for maps 2127 # now do the right thing for maps
1561 $self->link_multipart_objects; 2128 $self->link_multipart_objects;
1562 $self->difficulty ($self->estimate_difficulty) 2129 $self->difficulty ($self->estimate_difficulty)
1563 unless $self->difficulty; 2130 unless $self->difficulty;
1564 Coro::cede; 2131 cf::cede_to_tick;
1565 2132
1566 unless ($self->{deny_activate}) { 2133 unless ($self->{deny_activate}) {
1567 $self->decay_objects; 2134 $self->decay_objects;
1568 $self->fix_auto_apply; 2135 $self->fix_auto_apply;
1569 $self->update_buttons; 2136 $self->update_buttons;
1570 Coro::cede; 2137 cf::cede_to_tick;
1571 $self->set_darkness_map;
1572 Coro::cede;
1573 $self->activate; 2138 $self->activate;
1574 } 2139 }
1575 2140
2141 $self->{last_save} = $cf::RUNTIME;
2142 $self->last_access ($cf::RUNTIME);
2143
1576 $self->in_memory (cf::MAP_IN_MEMORY); 2144 $self->in_memory (cf::MAP_ACTIVE);
1577 } 2145 }
1578 2146
1579 $self->post_load; 2147 $self->post_load;
1580} 2148}
1581 2149
2150# customize the map for a given player, i.e.
2151# return the _real_ map. used by e.g. per-player
2152# maps to change the path to ~playername/mappath
1582sub customise_for { 2153sub customise_for {
1583 my ($self, $ob) = @_; 2154 my ($self, $ob) = @_;
1584 2155
1585 return find "~" . $ob->name . "/" . $self->{path} 2156 return find "~" . $ob->name . "/" . $self->{path}
1586 if $self->per_player; 2157 if $self->per_player;
1587 2158
2159# return find "?party/" . $ob->name . "/" . $self->{path}
2160# if $self->per_party;
2161
1588 $self 2162 $self
1589} 2163}
1590 2164
1591# find and load all maps in the 3x3 area around a map 2165# find and load all maps in the 3x3 area around a map
1592sub load_diag { 2166sub load_neighbours {
1593 my ($map) = @_; 2167 my ($map) = @_;
1594 2168
1595 my @diag; # diagonal neighbours 2169 my @neigh; # diagonal neighbours
1596 2170
1597 for (0 .. 3) { 2171 for (0 .. 3) {
1598 my $neigh = $map->tile_path ($_) 2172 my $neigh = $map->tile_path ($_)
1599 or next; 2173 or next;
1600 $neigh = find $neigh, $map 2174 $neigh = find $neigh, $map
1601 or next; 2175 or next;
1602 $neigh->load; 2176 $neigh->load;
1603 2177
2178 # now find the diagonal neighbours
2179 push @neigh,
1604 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2180 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1605 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2181 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1606 } 2182 }
1607 2183
1608 for (@diag) { 2184 for (grep defined $_->[0], @neigh) {
2185 my ($path, $origin) = @$_;
1609 my $neigh = find @$_ 2186 my $neigh = find $path, $origin
1610 or next; 2187 or next;
1611 $neigh->load; 2188 $neigh->load;
1612 } 2189 }
1613} 2190}
1614 2191
1615sub find_sync { 2192sub find_sync {
1616 my ($path, $origin) = @_; 2193 my ($path, $origin) = @_;
1617 2194
1618 cf::sync_job { find $path, $origin } 2195 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2196 if $Coro::current == $Coro::main;
2197
2198 find $path, $origin
1619} 2199}
1620 2200
1621sub do_load_sync { 2201sub do_load_sync {
1622 my ($map) = @_; 2202 my ($map) = @_;
1623 2203
1624 cf::sync_job { $map->load }; 2204 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2205 if $Coro::current == $Coro::main;
2206
2207 $map->load;
1625} 2208}
1626 2209
1627our %MAP_PREFETCH; 2210our %MAP_PREFETCH;
1628our $MAP_PREFETCHER = undef; 2211our $MAP_PREFETCHER = undef;
1629 2212
1630sub find_async { 2213sub find_async {
1631 my ($path, $origin) = @_; 2214 my ($path, $origin, $load) = @_;
1632 2215
1633 $path = normalise $path, $origin && $origin->{path}; 2216 $path = normalise $path, $origin && $origin->{path};
1634 2217
1635 if (my $map = $cf::MAP{$path}) { 2218 if (my $map = $cf::MAP{$path}) {
1636 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2219 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1637 } 2220 }
1638 2221
1639 undef $MAP_PREFETCH{$path}; 2222 $MAP_PREFETCH{$path} |= $load;
2223
1640 $MAP_PREFETCHER ||= cf::async { 2224 $MAP_PREFETCHER ||= cf::async {
2225 $Coro::current->{desc} = "map prefetcher";
2226
1641 while (%MAP_PREFETCH) { 2227 while (%MAP_PREFETCH) {
1642 for my $path (keys %MAP_PREFETCH) { 2228 while (my ($k, $v) = each %MAP_PREFETCH) {
1643 my $map = find $path 2229 if (my $map = find $k) {
1644 or next;
1645 $map->load; 2230 $map->load if $v;
2231 }
1646 2232
1647 delete $MAP_PREFETCH{$path}; 2233 delete $MAP_PREFETCH{$k};
1648 } 2234 }
1649 } 2235 }
1650 undef $MAP_PREFETCHER; 2236 undef $MAP_PREFETCHER;
1651 }; 2237 };
1652 $MAP_PREFETCHER->prio (6); 2238 $MAP_PREFETCHER->prio (6);
1653 2239
1654 () 2240 ()
1655} 2241}
1656 2242
2243# common code, used by both ->save and ->swapout
1657sub save { 2244sub _save {
1658 my ($self) = @_; 2245 my ($self) = @_;
1659
1660 my $lock = cf::lock_acquire "map_data:" . $self->path;
1661 2246
1662 $self->{last_save} = $cf::RUNTIME; 2247 $self->{last_save} = $cf::RUNTIME;
1663 2248
1664 return unless $self->dirty; 2249 return unless $self->dirty;
1665 2250
… …
1671 return if $self->{deny_save}; 2256 return if $self->{deny_save};
1672 2257
1673 local $self->{last_access} = $self->last_access;#d# 2258 local $self->{last_access} = $self->last_access;#d#
1674 2259
1675 cf::async { 2260 cf::async {
2261 $Coro::current->{desc} = "map player save";
1676 $_->contr->save for $self->players; 2262 $_->contr->save for $self->players;
1677 }; 2263 };
2264
2265 cf::get_slot 0.02;
1678 2266
1679 if ($uniq) { 2267 if ($uniq) {
1680 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2268 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1681 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2269 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1682 } else { 2270 } else {
1683 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2271 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1684 } 2272 }
1685} 2273}
1686 2274
2275sub save {
2276 my ($self) = @_;
2277
2278 my $lock = cf::lock_acquire "map_data:$self->{path}";
2279
2280 $self->_save;
2281}
2282
1687sub swap_out { 2283sub swap_out {
1688 my ($self) = @_; 2284 my ($self) = @_;
1689 2285
1690 # save first because save cedes
1691 $self->save;
1692
1693 my $lock = cf::lock_acquire "map_data:" . $self->path; 2286 my $lock = cf::lock_acquire "map_data:$self->{path}";
1694 2287
2288 return if $self->in_memory != cf::MAP_ACTIVE;
2289 return if $self->{deny_save};
1695 return if $self->players; 2290 return if $self->players;
1696 return if $self->in_memory != cf::MAP_IN_MEMORY;
1697 return if $self->{deny_save};
1698 2291
2292 # first deactivate the map and "unlink" it from the core
2293 $self->deactivate;
2294 $_->clear_links_to ($self) for values %cf::MAP;
2295 $self->in_memory (cf::MAP_SWAPPED);
2296
2297 # then atomically save
2298 $self->_save;
2299
2300 # then free the map
1699 $self->clear; 2301 $self->clear;
1700 $self->in_memory (cf::MAP_SWAPPED);
1701} 2302}
1702 2303
1703sub reset_at { 2304sub reset_at {
1704 my ($self) = @_; 2305 my ($self) = @_;
1705 2306
1706 # TODO: safety, remove and allow resettable per-player maps 2307 # TODO: safety, remove and allow resettable per-player maps
1707 return 1e99 if $self->isa ("ext::map_per_player");#d#
1708 return 1e99 if $self->{deny_reset}; 2308 return 1e99 if $self->{deny_reset};
1709 2309
1710 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2310 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1711 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2311 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1712 2312
… …
1723 my ($self) = @_; 2323 my ($self) = @_;
1724 2324
1725 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2325 my $lock = cf::lock_acquire "map_data:$self->{path}";
1726 2326
1727 return if $self->players; 2327 return if $self->players;
1728 return if $self->isa ("ext::map_per_player");#d#
1729 2328
1730 warn "resetting map ", $self->path;#d# 2329 cf::trace "resetting map ", $self->path, "\n";
1731 2330
1732 $self->in_memory (cf::MAP_SWAPPED); 2331 $self->in_memory (cf::MAP_SWAPPED);
1733 2332
1734 # need to save uniques path 2333 # need to save uniques path
1735 unless ($self->{deny_save}) { 2334 unless ($self->{deny_save}) {
… …
1739 if $uniq; 2338 if $uniq;
1740 } 2339 }
1741 2340
1742 delete $cf::MAP{$self->path}; 2341 delete $cf::MAP{$self->path};
1743 2342
2343 $self->deactivate;
2344 $_->clear_links_to ($self) for values %cf::MAP;
1744 $self->clear; 2345 $self->clear;
1745
1746 $_->clear_links_to ($self) for values %cf::MAP;
1747 2346
1748 $self->unlink_save; 2347 $self->unlink_save;
1749 $self->destroy; 2348 $self->destroy;
1750} 2349}
1751 2350
1752my $nuke_counter = "aaaa"; 2351my $nuke_counter = "aaaa";
1753 2352
1754sub nuke { 2353sub nuke {
1755 my ($self) = @_; 2354 my ($self) = @_;
1756 2355
2356 {
2357 my $lock = cf::lock_acquire "map_data:$self->{path}";
2358
1757 delete $cf::MAP{$self->path}; 2359 delete $cf::MAP{$self->path};
1758 2360
1759 $self->unlink_save; 2361 $self->unlink_save;
1760 2362
1761 bless $self, "cf::map"; 2363 bless $self, "cf::map::wrap";
1762 delete $self->{deny_reset}; 2364 delete $self->{deny_reset};
1763 $self->{deny_save} = 1; 2365 $self->{deny_save} = 1;
1764 $self->reset_timeout (1); 2366 $self->reset_timeout (1);
1765 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2367 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1766 2368
1767 $cf::MAP{$self->path} = $self; 2369 $cf::MAP{$self->path} = $self;
2370 }
1768 2371
1769 $self->reset; # polite request, might not happen 2372 $self->reset; # polite request, might not happen
2373}
2374
2375=item $maps = cf::map::tmp_maps
2376
2377Returns an arrayref with all map paths of currently instantiated and saved
2378maps. May block.
2379
2380=cut
2381
2382sub tmp_maps() {
2383 [
2384 map {
2385 utf8::decode $_;
2386 /\.map$/
2387 ? normalise $_
2388 : ()
2389 } @{ aio_readdir $TMPDIR or [] }
2390 ]
2391}
2392
2393=item $maps = cf::map::random_maps
2394
2395Returns an arrayref with all map paths of currently instantiated and saved
2396random maps. May block.
2397
2398=cut
2399
2400sub random_maps() {
2401 [
2402 map {
2403 utf8::decode $_;
2404 /\.map$/
2405 ? normalise "?random/$_"
2406 : ()
2407 } @{ aio_readdir $RANDOMDIR or [] }
2408 ]
1770} 2409}
1771 2410
1772=item cf::map::unique_maps 2411=item cf::map::unique_maps
1773 2412
1774Returns an arrayref of paths of all shared maps that have 2413Returns an arrayref of paths of all shared maps that have
1775instantiated unique items. May block. 2414instantiated unique items. May block.
1776 2415
1777=cut 2416=cut
1778 2417
1779sub unique_maps() { 2418sub unique_maps() {
1780 my $files = aio_readdir $UNIQUEDIR 2419 [
1781 or return; 2420 map {
1782
1783 my @paths;
1784
1785 for (@$files) {
1786 utf8::decode $_; 2421 utf8::decode $_;
1787 next if /\.pst$/; 2422 s/\.map$//; # TODO future compatibility hack
1788 next unless /^$PATH_SEP/o; 2423 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1789 2424 ? ()
1790 push @paths, cf::map::normalise $_; 2425 : normalise $_
2426 } @{ aio_readdir $UNIQUEDIR or [] }
1791 } 2427 ]
1792
1793 \@paths
1794} 2428}
1795 2429
1796package cf; 2430=item cf::map::static_maps
2431
2432Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2433file in the shared directory excluding F</styles> and F</editor>). May
2434block.
2435
2436=cut
2437
2438sub static_maps() {
2439 my @dirs = "";
2440 my @maps;
2441
2442 while (@dirs) {
2443 my $dir = shift @dirs;
2444
2445 next if $dir eq "/styles" || $dir eq "/editor";
2446
2447 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2448 or return;
2449
2450 for (@$files) {
2451 s/\.map$// or next;
2452 utf8::decode $_;
2453 push @maps, "$dir/$_";
2454 }
2455
2456 push @dirs, map "$dir/$_", @$dirs;
2457 }
2458
2459 \@maps
2460}
1797 2461
1798=back 2462=back
1799 2463
1800=head3 cf::object 2464=head3 cf::object
1801 2465
… …
1805 2469
1806=over 4 2470=over 4
1807 2471
1808=item $ob->inv_recursive 2472=item $ob->inv_recursive
1809 2473
1810Returns the inventory of the object _and_ their inventories, recursively. 2474Returns the inventory of the object I<and> their inventories, recursively,
2475but I<not> the object itself.
1811 2476
1812=cut 2477=cut
1813 2478
1814sub inv_recursive_; 2479sub inv_recursive_;
1815sub inv_recursive_ { 2480sub inv_recursive_ {
… …
1818 2483
1819sub inv_recursive { 2484sub inv_recursive {
1820 inv_recursive_ inv $_[0] 2485 inv_recursive_ inv $_[0]
1821} 2486}
1822 2487
2488=item $ref = $ob->ref
2489
2490Creates and returns a persistent reference to an object that can be stored as a string.
2491
2492=item $ob = cf::object::deref ($refstring)
2493
2494returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2495even if the object actually exists. May block.
2496
2497=cut
2498
2499sub deref {
2500 my ($ref) = @_;
2501
2502 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2503 my ($uuid, $name) = ($1, $2);
2504 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2505 or return;
2506 $pl->ob->uuid eq $uuid
2507 or return;
2508
2509 $pl->ob
2510 } else {
2511 warn "$ref: cannot resolve object reference\n";
2512 undef
2513 }
2514}
2515
1823package cf; 2516package cf;
1824 2517
1825=back 2518=back
1826 2519
1827=head3 cf::object::player 2520=head3 cf::object::player
… …
1833Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2526Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1834can be C<undef>. Does the right thing when the player is currently in a 2527can be C<undef>. Does the right thing when the player is currently in a
1835dialogue with the given NPC character. 2528dialogue with the given NPC character.
1836 2529
1837=cut 2530=cut
2531
2532our $SAY_CHANNEL = {
2533 id => "say",
2534 title => "Map",
2535 reply => "say ",
2536 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2537};
2538
2539our $CHAT_CHANNEL = {
2540 id => "chat",
2541 title => "Chat",
2542 reply => "chat ",
2543 tooltip => "Player chat and shouts, global to the server.",
2544};
1838 2545
1839# rough implementation of a future "reply" method that works 2546# rough implementation of a future "reply" method that works
1840# with dialog boxes. 2547# with dialog boxes.
1841#TODO: the first argument must go, split into a $npc->reply_to ( method 2548#TODO: the first argument must go, split into a $npc->reply_to ( method
1842sub cf::object::player::reply($$$;$) { 2549sub cf::object::player::reply($$$;$) {
… …
1844 2551
1845 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2552 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1846 2553
1847 if ($self->{record_replies}) { 2554 if ($self->{record_replies}) {
1848 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2555 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2556
1849 } else { 2557 } else {
2558 my $pl = $self->contr;
2559
2560 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2561 my $dialog = $pl->{npc_dialog};
2562 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2563
2564 } else {
1850 $msg = $npc->name . " says: $msg" if $npc; 2565 $msg = $npc->name . " says: $msg" if $npc;
1851 $self->message ($msg, $flags); 2566 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2567 }
1852 } 2568 }
2569}
2570
2571=item $object->send_msg ($channel, $msg, $color, [extra...])
2572
2573=cut
2574
2575sub cf::object::send_msg {
2576 my $pl = shift->contr
2577 or return;
2578 $pl->send_msg (@_);
1853} 2579}
1854 2580
1855=item $player_object->may ("access") 2581=item $player_object->may ("access")
1856 2582
1857Returns wether the given player is authorized to access resource "access" 2583Returns wether the given player is authorized to access resource "access"
… …
1870 2596
1871=item $player_object->enter_link 2597=item $player_object->enter_link
1872 2598
1873Freezes the player and moves him/her to a special map (C<{link}>). 2599Freezes the player and moves him/her to a special map (C<{link}>).
1874 2600
1875The player should be reasonably safe there for short amounts of time. You 2601The player should be reasonably safe there for short amounts of time (e.g.
1876I<MUST> call C<leave_link> as soon as possible, though. 2602for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2603though, as the player cannot control the character while it is on the link
2604map.
1877 2605
1878Will never block. 2606Will never block.
1879 2607
1880=item $player_object->leave_link ($map, $x, $y) 2608=item $player_object->leave_link ($map, $x, $y)
1881 2609
… …
1901sub cf::object::player::enter_link { 2629sub cf::object::player::enter_link {
1902 my ($self) = @_; 2630 my ($self) = @_;
1903 2631
1904 $self->deactivate_recursive; 2632 $self->deactivate_recursive;
1905 2633
2634 ++$self->{_link_recursion};
2635
1906 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2636 return if UNIVERSAL::isa $self->map, "ext::map_link";
1907 2637
1908 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2638 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1909 if $self->map; 2639 if $self->map && $self->map->{path} ne "{link}";
1910 2640
1911 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2641 $self->enter_map ($LINK_MAP || link_map, 3, 3);
1912} 2642}
1913 2643
1914sub cf::object::player::leave_link { 2644sub cf::object::player::leave_link {
1915 my ($self, $map, $x, $y) = @_; 2645 my ($self, $map, $x, $y) = @_;
2646
2647 return unless $self->contr->active;
1916 2648
1917 my $link_pos = delete $self->{_link_pos}; 2649 my $link_pos = delete $self->{_link_pos};
1918 2650
1919 unless ($map) { 2651 unless ($map) {
1920 # restore original map position 2652 # restore original map position
… …
1931 ($x, $y) = (-1, -1) 2663 ($x, $y) = (-1, -1)
1932 unless (defined $x) && (defined $y); 2664 unless (defined $x) && (defined $y);
1933 2665
1934 # use -1 or undef as default coordinates, not 0, 0 2666 # use -1 or undef as default coordinates, not 0, 0
1935 ($x, $y) = ($map->enter_x, $map->enter_y) 2667 ($x, $y) = ($map->enter_x, $map->enter_y)
1936 if $x <=0 && $y <= 0; 2668 if $x <= 0 && $y <= 0;
1937 2669
1938 $map->load; 2670 $map->load;
1939 $map->load_diag; 2671 $map->load_neighbours;
1940 2672
1941 return unless $self->contr->active; 2673 return unless $self->contr->active;
1942 $self->activate_recursive;
1943 2674
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2675 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1945 $self->enter_map ($map, $x, $y); 2676 if ($self->enter_map ($map, $x, $y)) {
1946} 2677 # entering was successful
1947 2678 delete $self->{_link_recursion};
1948cf::player->attach ( 2679 # only activate afterwards, to support waiting in hooks
1949 on_logout => sub { 2680 $self->activate_recursive;
1950 my ($pl) = @_;
1951
1952 # abort map switching before logout
1953 if ($pl->ob->{_link_pos}) {
1954 cf::sync_job {
1955 $pl->ob->leave_link
1956 };
1957 }
1958 }, 2681 }
1959 on_login => sub {
1960 my ($pl) = @_;
1961 2682
1962 # try to abort aborted map switching on player login :) 2683}
1963 # should happen only on crashes
1964 if ($pl->ob->{_link_pos}) {
1965 $pl->ob->enter_link;
1966 (async {
1967 $pl->ob->reply (undef,
1968 "There was an internal problem at your last logout, "
1969 . "the server will try to bring you to your intended destination in a second.",
1970 cf::NDI_RED);
1971 # we need this sleep as the login has a concurrent enter_exit running
1972 # and this sleep increases chances of the player not ending up in scorn
1973 Coro::Timer::sleep 1;
1974 $pl->ob->leave_link;
1975 })->prio (2);
1976 }
1977 },
1978);
1979 2684
1980=item $player_object->goto ($path, $x, $y) 2685=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
1981 2686
2687Moves the player to the given map-path and coordinates by first freezing
2688her, loading and preparing them map, calling the provided $check callback
2689that has to return the map if sucecssful, and then unfreezes the player on
2690the new (success) or old (failed) map position. In either case, $done will
2691be called at the end of this process.
2692
2693Note that $check will be called with a potentially non-loaded map, so if
2694it needs a loaded map it has to call C<< ->load >>.
2695
1982=cut 2696=cut
2697
2698our $GOTOGEN;
1983 2699
1984sub cf::object::player::goto { 2700sub cf::object::player::goto {
1985 my ($self, $path, $x, $y) = @_; 2701 my ($self, $path, $x, $y, $check, $done) = @_;
2702
2703 if ($self->{_link_recursion} >= $MAX_LINKS) {
2704 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2705 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2706 ($path, $x, $y) = @$EMERGENCY_POSITION;
2707 }
2708
2709 # do generation counting so two concurrent goto's will be executed in-order
2710 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1986 2711
1987 $self->enter_link; 2712 $self->enter_link;
1988 2713
1989 (async { 2714 (async {
2715 $Coro::current->{desc} = "player::goto $path $x $y";
2716
2717 # *tag paths override both path and x|y
2718 if ($path =~ /^\*(.*)$/) {
2719 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2720 my $ob = $obs[rand @obs];
2721
2722 # see if we actually can go there
2723 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2724 $ob = $obs[rand @obs];
2725 } else {
2726 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2727 }
2728 # else put us there anyways for now #d#
2729
2730 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2731 } else {
2732 ($path, $x, $y) = (undef, undef, undef);
2733 }
2734 }
2735
1990 my $map = eval { 2736 my $map = eval {
1991 my $map = cf::map::find $path; 2737 my $map = defined $path ? cf::map::find $path : undef;
2738
2739 if ($map) {
1992 $map = $map->customise_for ($self) if $map; 2740 $map = $map->customise_for ($self);
2741 $map = $check->($map, $x, $y, $self) if $check && $map;
2742 } else {
2743 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2744 }
2745
1993 $map 2746 $map
2747 };
2748
2749 if ($@) {
2750 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2751 LOG llevError | logBacktrace, Carp::longmess $@;
1994 } or 2752 }
1995 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1996 2753
2754 if ($gen == $self->{_goto_generation}) {
2755 delete $self->{_goto_generation};
1997 $self->leave_link ($map, $x, $y); 2756 $self->leave_link ($map, $x, $y);
2757 }
2758
2759 $done->($self) if $done;
1998 })->prio (1); 2760 })->prio (1);
1999} 2761}
2000 2762
2001=item $player_object->enter_exit ($exit_object) 2763=item $player_object->enter_exit ($exit_object)
2002 2764
… …
2022} 2784}
2023 2785
2024sub prepare_random_map { 2786sub prepare_random_map {
2025 my ($exit) = @_; 2787 my ($exit) = @_;
2026 2788
2027 my $guard = cf::lock_acquire "exit_prepare:$exit";
2028
2029 # all this does is basically replace the /! path by 2789 # all this does is basically replace the /! path by
2030 # a new random map path (?random/...) with a seed 2790 # a new random map path (?random/...) with a seed
2031 # that depends on the exit object 2791 # that depends on the exit object
2032 2792
2033 my $rmp = parse_random_map_params $exit->msg; 2793 my $rmp = parse_random_map_params $exit->msg;
… …
2035 if ($exit->map) { 2795 if ($exit->map) {
2036 $rmp->{region} = $exit->region->name; 2796 $rmp->{region} = $exit->region->name;
2037 $rmp->{origin_map} = $exit->map->path; 2797 $rmp->{origin_map} = $exit->map->path;
2038 $rmp->{origin_x} = $exit->x; 2798 $rmp->{origin_x} = $exit->x;
2039 $rmp->{origin_y} = $exit->y; 2799 $rmp->{origin_y} = $exit->y;
2800
2801 $exit->map->touch;
2040 } 2802 }
2041 2803
2042 $rmp->{random_seed} ||= $exit->random_seed; 2804 $rmp->{random_seed} ||= $exit->random_seed;
2043 2805
2044 my $data = cf::to_json $rmp; 2806 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2045 my $md5 = Digest::MD5::md5_hex $data; 2807 my $md5 = Digest::MD5::md5_hex $data;
2046 my $meta = "$RANDOMDIR/$md5.meta"; 2808 my $meta = "$RANDOMDIR/$md5.meta";
2047 2809
2048 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2810 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2049 aio_write $fh, 0, (length $data), $data, 0; 2811 aio_write $fh, 0, (length $data), $data, 0;
2050 undef $fh; 2812 undef $fh;
2051 aio_rename "$meta~", $meta; 2813 aio_rename "$meta~", $meta;
2052 2814
2815 my $slaying = "?random/$md5";
2816
2817 if ($exit->valid) {
2053 $exit->slaying ("?random/$md5"); 2818 $exit->slaying ("?random/$md5");
2054 $exit->msg (undef); 2819 $exit->msg (undef);
2820 }
2055 } 2821 }
2056} 2822}
2057 2823
2058sub cf::object::player::enter_exit { 2824sub cf::object::player::enter_exit {
2059 my ($self, $exit) = @_; 2825 my ($self, $exit) = @_;
2060 2826
2061 return unless $self->type == cf::PLAYER; 2827 return unless $self->type == cf::PLAYER;
2062 2828
2063 if ($exit->slaying eq "/!") {
2064 #TODO: this should de-fi-ni-te-ly not be a sync-job
2065 # the problem is that $exit might not survive long enough
2066 # so it needs to be done right now, right here
2067 cf::sync_job { prepare_random_map $exit };
2068 }
2069
2070 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2071 my $hp = $exit->stats->hp;
2072 my $sp = $exit->stats->sp;
2073
2074 $self->enter_link; 2829 $self->enter_link;
2075 2830
2076 (async { 2831 (async {
2077 $self->deactivate_recursive; # just to be sure 2832 $Coro::current->{desc} = "enter_exit";
2833
2078 unless (eval { 2834 unless (eval {
2835 $self->deactivate_recursive; # just to be sure
2836
2837 # random map handling
2838 {
2839 my $guard = cf::lock_acquire "exit_prepare:$exit";
2840
2841 prepare_random_map $exit
2842 if $exit->slaying eq "/!";
2843 }
2844
2845 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2846 my $x = $exit->stats->hp;
2847 my $y = $exit->stats->sp;
2848
2079 $self->goto ($slaying, $hp, $sp); 2849 $self->goto ($map, $x, $y);
2080 2850
2851 # if exit is damned, update players death & WoR home-position
2852 $self->contr->savebed ($map, $x, $y)
2853 if $exit->flag (cf::FLAG_DAMNED);
2854
2081 1; 2855 1
2082 }) { 2856 }) {
2083 $self->message ("Something went wrong deep within the crossfire server. " 2857 $self->message ("Something went wrong deep within the deliantra server. "
2084 . "I'll try to bring you back to the map you were before. " 2858 . "I'll try to bring you back to the map you were before. "
2085 . "Please report this to the dungeon master!", 2859 . "Please report this to the dungeon master!",
2086 cf::NDI_UNIQUE | cf::NDI_RED); 2860 cf::NDI_UNIQUE | cf::NDI_RED);
2087 2861
2088 warn "ERROR in enter_exit: $@"; 2862 error "ERROR in enter_exit: $@";
2089 $self->leave_link; 2863 $self->leave_link;
2090 } 2864 }
2091 })->prio (1); 2865 })->prio (1);
2092} 2866}
2093 2867
… …
2107 2881
2108 utf8::encode $text; 2882 utf8::encode $text;
2109 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2883 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2110} 2884}
2111 2885
2886=item $client->send_big_packet ($pkt)
2887
2888Like C<send_packet>, but tries to compress large packets, and fragments
2889them as required.
2890
2891=cut
2892
2893our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2894
2895sub cf::client::send_big_packet {
2896 my ($self, $pkt) = @_;
2897
2898 # try lzf for large packets
2899 $pkt = "lzf " . Compress::LZF::compress $pkt
2900 if 1024 <= length $pkt and $self->{can_lzf};
2901
2902 # split very large packets
2903 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2904 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2905 $pkt = "frag";
2906 }
2907
2908 $self->send_packet ($pkt);
2909}
2910
2911=item $client->send_msg ($channel, $msg, $color, [extra...])
2912
2913Send a drawinfo or msg packet to the client, formatting the msg for the
2914client if neccessary. C<$type> should be a string identifying the type of
2915the message, with C<log> being the default. If C<$color> is negative, suppress
2916the message unless the client supports the msg packet.
2917
2918=cut
2919
2920# non-persistent channels (usually the info channel)
2921our %CHANNEL = (
2922 "c/motd" => {
2923 id => "infobox",
2924 title => "MOTD",
2925 reply => undef,
2926 tooltip => "The message of the day",
2927 },
2928 "c/identify" => {
2929 id => "infobox",
2930 title => "Identify",
2931 reply => undef,
2932 tooltip => "Items recently identified",
2933 },
2934 "c/examine" => {
2935 id => "infobox",
2936 title => "Examine",
2937 reply => undef,
2938 tooltip => "Signs and other items you examined",
2939 },
2940 "c/shopinfo" => {
2941 id => "infobox",
2942 title => "Shop Info",
2943 reply => undef,
2944 tooltip => "What your bargaining skill tells you about the shop",
2945 },
2946 "c/book" => {
2947 id => "infobox",
2948 title => "Book",
2949 reply => undef,
2950 tooltip => "The contents of a note or book",
2951 },
2952 "c/lookat" => {
2953 id => "infobox",
2954 title => "Look",
2955 reply => undef,
2956 tooltip => "What you saw there",
2957 },
2958 "c/who" => {
2959 id => "infobox",
2960 title => "Players",
2961 reply => undef,
2962 tooltip => "Shows players who are currently online",
2963 },
2964 "c/body" => {
2965 id => "infobox",
2966 title => "Body Parts",
2967 reply => undef,
2968 tooltip => "Shows which body parts you posess and are available",
2969 },
2970 "c/statistics" => {
2971 id => "infobox",
2972 title => "Statistics",
2973 reply => undef,
2974 tooltip => "Shows your primary statistics",
2975 },
2976 "c/skills" => {
2977 id => "infobox",
2978 title => "Skills",
2979 reply => undef,
2980 tooltip => "Shows your experience per skill and item power",
2981 },
2982 "c/shopitems" => {
2983 id => "infobox",
2984 title => "Shop Items",
2985 reply => undef,
2986 tooltip => "Shows the items currently for sale in this shop",
2987 },
2988 "c/resistances" => {
2989 id => "infobox",
2990 title => "Resistances",
2991 reply => undef,
2992 tooltip => "Shows your resistances",
2993 },
2994 "c/pets" => {
2995 id => "infobox",
2996 title => "Pets",
2997 reply => undef,
2998 tooltip => "Shows information abotu your pets/a specific pet",
2999 },
3000 "c/perceiveself" => {
3001 id => "infobox",
3002 title => "Perceive Self",
3003 reply => undef,
3004 tooltip => "You gained detailed knowledge about yourself",
3005 },
3006 "c/uptime" => {
3007 id => "infobox",
3008 title => "Uptime",
3009 reply => undef,
3010 tooltip => "How long the server has been running since last restart",
3011 },
3012 "c/mapinfo" => {
3013 id => "infobox",
3014 title => "Map Info",
3015 reply => undef,
3016 tooltip => "Information related to the maps",
3017 },
3018 "c/party" => {
3019 id => "party",
3020 title => "Party",
3021 reply => "gsay ",
3022 tooltip => "Messages and chat related to your party",
3023 },
3024 "c/death" => {
3025 id => "death",
3026 title => "Death",
3027 reply => undef,
3028 tooltip => "Reason for and more info about your most recent death",
3029 },
3030 "c/say" => $SAY_CHANNEL,
3031 "c/chat" => $CHAT_CHANNEL,
3032);
3033
3034sub cf::client::send_msg {
3035 my ($self, $channel, $msg, $color, @extra) = @_;
3036
3037 $msg = $self->pl->expand_cfpod ($msg)
3038 unless $color & cf::NDI_VERBATIM;
3039
3040 $color &= cf::NDI_CLIENT_MASK; # just in case...
3041
3042 # check predefined channels, for the benefit of C
3043 if ($CHANNEL{$channel}) {
3044 $channel = $CHANNEL{$channel};
3045
3046 $self->ext_msg (channel_info => $channel);
3047 $channel = $channel->{id};
3048
3049 } elsif (ref $channel) {
3050 # send meta info to client, if not yet sent
3051 unless (exists $self->{channel}{$channel->{id}}) {
3052 $self->{channel}{$channel->{id}} = $channel;
3053 $self->ext_msg (channel_info => $channel);
3054 }
3055
3056 $channel = $channel->{id};
3057 }
3058
3059 return unless @extra || length $msg;
3060
3061 # default colour, mask it out
3062 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
3063 if $color & cf::NDI_DEF;
3064
3065 my $pkt = "msg "
3066 . $self->{json_coder}->encode (
3067 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
3068 );
3069
3070 $self->send_big_packet ($pkt);
3071}
3072
2112=item $client->ext_event ($type, %msg) 3073=item $client->ext_msg ($type, @msg)
2113 3074
2114Sends an exti event to the client. 3075Sends an ext event to the client.
2115 3076
2116=cut 3077=cut
2117 3078
2118sub cf::client::ext_event($$%) { 3079sub cf::client::ext_msg($$@) {
2119 my ($self, $type, %msg) = @_; 3080 my ($self, $type, @msg) = @_;
2120 3081
3082 if ($self->extcmd == 2) {
3083 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
3084 } elsif ($self->extcmd == 1) { # TODO: remove
2121 $msg{msgtype} = "event_$type"; 3085 push @msg, msgtype => "event_$type";
2122 $self->send_packet ("ext " . cf::to_json \%msg); 3086 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3087 }
3088}
3089
3090=item $client->ext_reply ($msgid, @msg)
3091
3092Sends an ext reply to the client.
3093
3094=cut
3095
3096sub cf::client::ext_reply($$@) {
3097 my ($self, $id, @msg) = @_;
3098
3099 if ($self->extcmd == 2) {
3100 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
3101 } elsif ($self->extcmd == 1) {
3102 #TODO: version 1, remove
3103 unshift @msg, msgtype => "reply", msgid => $id;
3104 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
3105 }
2123} 3106}
2124 3107
2125=item $success = $client->query ($flags, "text", \&cb) 3108=item $success = $client->query ($flags, "text", \&cb)
2126 3109
2127Queues a query to the client, calling the given callback with 3110Queues a query to the client, calling the given callback with
2128the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 3111the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2129C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 3112C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2130 3113
2131Queries can fail, so check the return code. Or don't, as queries will become 3114Queries can fail, so check the return code. Or don't, as queries will
2132reliable at some point in the future. 3115become reliable at some point in the future.
2133 3116
2134=cut 3117=cut
2135 3118
2136sub cf::client::query { 3119sub cf::client::query {
2137 my ($self, $flags, $text, $cb) = @_; 3120 my ($self, $flags, $text, $cb) = @_;
… …
2145 utf8::encode $text; 3128 utf8::encode $text;
2146 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3129 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2147 3130
2148 $self->send_packet ($self->{query_queue}[0][0]) 3131 $self->send_packet ($self->{query_queue}[0][0])
2149 if @{ $self->{query_queue} } == 1; 3132 if @{ $self->{query_queue} } == 1;
3133
3134 1
2150} 3135}
2151 3136
2152cf::client->attach ( 3137cf::client->attach (
3138 on_connect => sub {
3139 my ($ns) = @_;
3140
3141 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3142 },
2153 on_reply => sub { 3143 on_reply => sub {
2154 my ($ns, $msg) = @_; 3144 my ($ns, $msg) = @_;
2155 3145
2156 # this weird shuffling is so that direct followup queries 3146 # this weird shuffling is so that direct followup queries
2157 # get handled first 3147 # get handled first
… …
2169 } else { 3159 } else {
2170 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3160 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2171 } 3161 }
2172 } 3162 }
2173 }, 3163 },
3164 on_exticmd => sub {
3165 my ($ns, $buf) = @_;
3166
3167 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3168
3169 if (ref $msg) {
3170 my ($type, $reply, @payload) =
3171 "ARRAY" eq ref $msg
3172 ? @$msg
3173 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3174
3175 my @reply;
3176
3177 if (my $cb = $EXTICMD{$type}) {
3178 @reply = $cb->($ns, @payload);
3179 }
3180
3181 $ns->ext_reply ($reply, @reply)
3182 if $reply;
3183
3184 } else {
3185 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3186 }
3187
3188 cf::override;
3189 },
2174); 3190);
2175 3191
2176=item $client->async (\&cb) 3192=item $client->async (\&cb)
2177 3193
2178Create a new coroutine, running the specified callback. The coroutine will 3194Create a new coroutine, running the specified callback. The coroutine will
… …
2194 3210
2195 $coro 3211 $coro
2196} 3212}
2197 3213
2198cf::client->attach ( 3214cf::client->attach (
2199 on_destroy => sub { 3215 on_client_destroy => sub {
2200 my ($ns) = @_; 3216 my ($ns) = @_;
2201 3217
2202 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3218 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2203 }, 3219 },
2204); 3220);
… …
2219our $safe = new Safe "safe"; 3235our $safe = new Safe "safe";
2220our $safe_hole = new Safe::Hole; 3236our $safe_hole = new Safe::Hole;
2221 3237
2222$SIG{FPE} = 'IGNORE'; 3238$SIG{FPE} = 'IGNORE';
2223 3239
2224$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3240$safe->permit_only (Opcode::opset qw(
3241 :base_core :base_mem :base_orig :base_math :base_loop
3242 grepstart grepwhile mapstart mapwhile
3243 sort time
3244));
2225 3245
2226# here we export the classes and methods available to script code 3246# here we export the classes and methods available to script code
2227 3247
2228=pod 3248=pod
2229 3249
2230The following functions and methods are available within a safe environment: 3250The following functions and methods are available within a safe environment:
2231 3251
2232 cf::object contr pay_amount pay_player map 3252 cf::object
3253 contr pay_amount pay_player map x y force_find force_add destroy
3254 insert remove name archname title slaying race decrease split
3255 value
3256
2233 cf::object::player player 3257 cf::object::player
2234 cf::player peaceful 3258 player
2235 cf::map trigger 3259
3260 cf::player
3261 peaceful
3262
3263 cf::map
3264 trigger
2236 3265
2237=cut 3266=cut
2238 3267
2239for ( 3268for (
2240 ["cf::object" => qw(contr pay_amount pay_player map)], 3269 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3270 insert remove inv nrof name archname title slaying race
3271 decrease split destroy change_exp value msg lore send_msg)],
2241 ["cf::object::player" => qw(player)], 3272 ["cf::object::player" => qw(player)],
2242 ["cf::player" => qw(peaceful)], 3273 ["cf::player" => qw(peaceful send_msg)],
2243 ["cf::map" => qw(trigger)], 3274 ["cf::map" => qw(trigger)],
2244) { 3275) {
2245 no strict 'refs';
2246 my ($pkg, @funs) = @$_; 3276 my ($pkg, @funs) = @$_;
2247 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3277 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2248 for @funs; 3278 for @funs;
2249} 3279}
2250 3280
… …
2265 3295
2266 my $qcode = $code; 3296 my $qcode = $code;
2267 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3297 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2268 $qcode =~ s/\n/\\n/g; 3298 $qcode =~ s/\n/\\n/g;
2269 3299
3300 %vars = (_dummy => 0) unless %vars;
3301
3302 my @res;
2270 local $_; 3303 local $_;
2271 local @safe::cf::_safe_eval_args = values %vars;
2272 3304
2273 my $eval = 3305 my $eval =
2274 "do {\n" 3306 "do {\n"
2275 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3307 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2276 . "#line 0 \"{$qcode}\"\n" 3308 . "#line 0 \"{$qcode}\"\n"
2277 . $code 3309 . $code
2278 . "\n}" 3310 . "\n}"
2279 ; 3311 ;
2280 3312
3313 if ($CFG{safe_eval}) {
2281 sub_generation_inc; 3314 sub_generation_inc;
3315 local @safe::cf::_safe_eval_args = values %vars;
2282 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3316 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2283 sub_generation_inc; 3317 sub_generation_inc;
3318 } else {
3319 local @cf::_safe_eval_args = values %vars;
3320 @res = wantarray ? eval eval : scalar eval $eval;
3321 }
2284 3322
2285 if ($@) { 3323 if ($@) {
2286 warn "$@"; 3324 warn "$@",
2287 warn "while executing safe code '$code'\n"; 3325 "while executing safe code '$code'\n",
2288 warn "with arguments " . (join " ", %vars) . "\n"; 3326 "with arguments " . (join " ", %vars) . "\n";
2289 } 3327 }
2290 3328
2291 wantarray ? @res : $res[0] 3329 wantarray ? @res : $res[0]
2292} 3330}
2293 3331
… …
2307=cut 3345=cut
2308 3346
2309sub register_script_function { 3347sub register_script_function {
2310 my ($fun, $cb) = @_; 3348 my ($fun, $cb) = @_;
2311 3349
2312 no strict 'refs'; 3350 $fun = "safe::$fun" if $CFG{safe_eval};
2313 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3351 *$fun = $safe_hole->wrap ($cb);
2314} 3352}
2315 3353
2316=back 3354=back
2317 3355
2318=cut 3356=cut
2319
2320#############################################################################
2321
2322=head2 EXTENSION DATABASE SUPPORT
2323
2324Crossfire maintains a very simple database for extension use. It can
2325currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2326convert to/from binary).
2327
2328The parameter C<$family> should best start with the name of the extension
2329using it, it should be unique.
2330
2331=over 4
2332
2333=item $value = cf::db_get $family => $key
2334
2335Returns a single value from the database.
2336
2337=item cf::db_put $family => $key => $value
2338
2339Stores the given C<$value> in the family.
2340
2341=cut
2342
2343our $DB;
2344
2345sub db_init {
2346 unless ($DB) {
2347 $DB = BDB::db_create $DB_ENV;
2348
2349 cf::sync_job {
2350 eval {
2351 $DB->set_flags (BDB::CHKSUM);
2352
2353 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2354 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2355 cf::cleanup "db_open(db): $!" if $!;
2356 };
2357 cf::cleanup "db_open(db): $@" if $@;
2358 };
2359 }
2360}
2361
2362sub db_get($$) {
2363 my $key = "$_[0]/$_[1]";
2364
2365 cf::sync_job {
2366 BDB::db_get $DB, undef, $key, my $data;
2367
2368 $! ? ()
2369 : $data
2370 }
2371}
2372
2373sub db_put($$$) {
2374 BDB::dbreq_pri 4;
2375 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2376}
2377
2378=item cf::cache $id => [$paths...], $processversion => $process
2379
2380Generic caching function that returns the value of the resource $id,
2381caching and regenerating as required.
2382
2383This function can block.
2384
2385=cut
2386
2387sub cache {
2388 my ($id, $src, $processversion, $process) = @_;
2389
2390 my $meta =
2391 join "\x00",
2392 $processversion,
2393 map {
2394 aio_stat $_
2395 and Carp::croak "$_: $!";
2396
2397 ($_, (stat _)[7,9])
2398 } @$src;
2399
2400 my $dbmeta = db_get cache => "$id/meta";
2401 if ($dbmeta ne $meta) {
2402 # changed, we may need to process
2403
2404 my @data;
2405 my $md5;
2406
2407 for (0 .. $#$src) {
2408 0 <= aio_load $src->[$_], $data[$_]
2409 or Carp::croak "$src->[$_]: $!";
2410 }
2411
2412 # if processing is expensive, check
2413 # checksum first
2414 if (1) {
2415 $md5 =
2416 join "\x00",
2417 $processversion,
2418 map {
2419 Coro::cede;
2420 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2421 } 0.. $#$src;
2422
2423
2424 my $dbmd5 = db_get cache => "$id/md5";
2425 if ($dbmd5 eq $md5) {
2426 db_put cache => "$id/meta", $meta;
2427
2428 return db_get cache => "$id/data";
2429 }
2430 }
2431
2432 my $t1 = Time::HiRes::time;
2433 my $data = $process->(\@data);
2434 my $t2 = Time::HiRes::time;
2435
2436 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2437
2438 db_put cache => "$id/data", $data;
2439 db_put cache => "$id/md5" , $md5;
2440 db_put cache => "$id/meta", $meta;
2441
2442 return $data;
2443 }
2444
2445 db_get cache => "$id/data"
2446}
2447
2448=item fork_call { }, $args
2449
2450Executes the given code block with the given arguments in a seperate
2451process, returning the results. Everything must be serialisable with
2452Coro::Storable. May, of course, block. Note that the executed sub may
2453never block itself or use any form of Event handling.
2454
2455=cut
2456
2457sub fork_call(&@) {
2458 my ($cb, @args) = @_;
2459
2460# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2461# or die "socketpair: $!";
2462 pipe my $fh1, my $fh2
2463 or die "pipe: $!";
2464
2465 if (my $pid = fork) {
2466 close $fh2;
2467
2468 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2469 $res = Coro::Storable::thaw $res;
2470
2471 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2472
2473 die $$res unless "ARRAY" eq ref $res;
2474
2475 return wantarray ? @$res : $res->[-1];
2476 } else {
2477 reset_signals;
2478 local $SIG{__WARN__};
2479 local $SIG{__DIE__};
2480 eval {
2481 close $fh1;
2482
2483 my @res = eval { $cb->(@args) };
2484 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2485 };
2486
2487 warn $@ if $@;
2488 _exit 0;
2489 }
2490}
2491
2492
2493 3357
2494############################################################################# 3358#############################################################################
2495# the server's init and main functions 3359# the server's init and main functions
2496 3360
2497sub load_facedata($) { 3361sub load_facedata($) {
2498 my ($path) = @_; 3362 my ($path) = @_;
2499 3363
3364 # HACK to clear player env face cache, we need some signal framework
3365 # for this (global event?)
3366 %ext::player_env::MUSIC_FACE_CACHE = ();
3367
3368 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3369
2500 warn "loading facedata from $path\n"; 3370 trace "loading facedata from $path\n";
2501 3371
2502 my $facedata; 3372 my $facedata;
2503 0 < aio_load $path, $facedata 3373 0 < aio_load $path, $facedata
2504 or die "$path: $!"; 3374 or die "$path: $!";
2505 3375
2506 $facedata = Coro::Storable::thaw $facedata; 3376 $facedata = Coro::Storable::thaw $facedata;
2507 3377
2508 $facedata->{version} == 2 3378 $facedata->{version} == 2
2509 or cf::cleanup "$path: version mismatch, cannot proceed."; 3379 or cf::cleanup "$path: version mismatch, cannot proceed.";
2510 3380
3381 # patch in the exptable
3382 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
3383 $facedata->{resource}{"res/exp_table"} = {
3384 type => FT_RSRC,
3385 data => $exp_table,
3386 hash => (Digest::MD5::md5 $exp_table),
3387 };
3388 cf::cede_to_tick;
3389
2511 { 3390 {
2512 my $faces = $facedata->{faceinfo}; 3391 my $faces = $facedata->{faceinfo};
2513 3392
2514 while (my ($face, $info) = each %$faces) { 3393 while (my ($face, $info) = each %$faces) {
2515 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3394 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3395
2516 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3396 cf::face::set_visibility $idx, $info->{visibility};
3397 cf::face::set_magicmap $idx, $info->{magicmap};
2517 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3398 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2518 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3399 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2519 Coro::cede; 3400
3401 cf::cede_to_tick;
2520 } 3402 }
2521 3403
2522 while (my ($face, $info) = each %$faces) { 3404 while (my ($face, $info) = each %$faces) {
2523 next unless $info->{smooth}; 3405 next unless $info->{smooth};
3406
2524 my $idx = cf::face::find $face 3407 my $idx = cf::face::find $face
2525 or next; 3408 or next;
3409
2526 if (my $smooth = cf::face::find $info->{smooth}) { 3410 if (my $smooth = cf::face::find $info->{smooth}) {
3411 cf::face::set_smooth $idx, $smooth;
2527 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3412 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2528 } else { 3413 } else {
2529 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3414 error "smooth face '$info->{smooth}' not found for face '$face'";
2530 } 3415 }
2531 Coro::cede; 3416
3417 cf::cede_to_tick;
2532 } 3418 }
2533 } 3419 }
2534 3420
2535 { 3421 {
2536 my $anims = $facedata->{animinfo}; 3422 my $anims = $facedata->{animinfo};
2537 3423
2538 while (my ($anim, $info) = each %$anims) { 3424 while (my ($anim, $info) = each %$anims) {
2539 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3425 cf::anim::set $anim, $info->{frames}, $info->{facings};
2540 Coro::cede; 3426 cf::cede_to_tick;
2541 } 3427 }
2542 3428
2543 cf::anim::invalidate_all; # d'oh 3429 cf::anim::invalidate_all; # d'oh
2544 } 3430 }
2545 3431
3432 {
3433 my $res = $facedata->{resource};
3434
3435 while (my ($name, $info) = each %$res) {
3436 if (defined $info->{type}) {
3437 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3438
3439 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3440 cf::face::set_type $idx, $info->{type};
3441 } else {
3442 $RESOURCE{$name} = $info; # unused
3443 }
3444
3445 cf::cede_to_tick;
3446 }
3447 }
3448
3449 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3450
2546 1 3451 1
2547} 3452}
2548 3453
3454register_exticmd fx_want => sub {
3455 my ($ns, $want) = @_;
3456
3457 while (my ($k, $v) = each %$want) {
3458 $ns->fx_want ($k, $v);
3459 }
3460};
3461
3462sub load_resource_file($) {
3463 my $guard = lock_acquire "load_resource_file";
3464
3465 my $status = load_resource_file_ $_[0];
3466 get_slot 0.1, 100;
3467 cf::arch::commit_load;
3468
3469 $status
3470}
3471
2549sub reload_regions { 3472sub reload_regions {
3473 # HACK to clear player env face cache, we need some signal framework
3474 # for this (global event?)
3475 %ext::player_env::MUSIC_FACE_CACHE = ();
3476
2550 load_resource_file "$MAPDIR/regions" 3477 load_resource_file "$MAPDIR/regions"
2551 or die "unable to load regions file\n"; 3478 or die "unable to load regions file\n";
3479
3480 for (cf::region::list) {
3481 $_->{match} = qr/$_->{match}/
3482 if exists $_->{match};
3483 }
2552} 3484}
2553 3485
2554sub reload_facedata { 3486sub reload_facedata {
2555 load_facedata "$DATADIR/facedata" 3487 load_facedata "$DATADIR/facedata"
2556 or die "unable to load facedata\n"; 3488 or die "unable to load facedata\n";
… …
2564sub reload_treasures { 3496sub reload_treasures {
2565 load_resource_file "$DATADIR/treasures" 3497 load_resource_file "$DATADIR/treasures"
2566 or die "unable to load treasurelists\n"; 3498 or die "unable to load treasurelists\n";
2567} 3499}
2568 3500
3501sub reload_sound {
3502 trace "loading sound config from $DATADIR/sound\n";
3503
3504 0 < Coro::AIO::aio_load "$DATADIR/sound", my $data
3505 or die "$DATADIR/sound $!";
3506
3507 my $soundconf = JSON::XS->new->utf8->relaxed->decode ($data);
3508
3509 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3510 my $sound = $soundconf->{compat}[$_]
3511 or next;
3512
3513 my $face = cf::face::find "sound/$sound->[1]";
3514 cf::sound::set $sound->[0] => $face;
3515 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3516 }
3517
3518 while (my ($k, $v) = each %{$soundconf->{event}}) {
3519 my $face = cf::face::find "sound/$v";
3520 cf::sound::set $k => $face;
3521 }
3522}
3523
2569sub reload_resources { 3524sub reload_resources {
2570 warn "reloading resource files...\n"; 3525 trace "reloading resource files...\n";
2571 3526
3527 reload_facedata;
3528 reload_sound;
3529 reload_archetypes;
2572 reload_regions; 3530 reload_regions;
2573 reload_facedata;
2574 reload_archetypes;
2575 reload_treasures; 3531 reload_treasures;
2576 3532
2577 warn "finished reloading resource files\n"; 3533 trace "finished reloading resource files\n";
2578} 3534}
2579 3535
2580sub init { 3536sub reload_config {
2581 reload_resources; 3537 trace "reloading config file...\n";
2582}
2583 3538
2584sub cfg_load {
2585 open my $fh, "<:utf8", "$CONFDIR/config" 3539 open my $fh, "<:utf8", "$CONFDIR/config"
2586 or return; 3540 or return;
2587 3541
2588 local $/; 3542 local $/;
2589 *CFG = YAML::Syck::Load <$fh>; 3543 *CFG = YAML::XS::Load scalar <$fh>;
2590 3544
2591 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3545 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
2592 3546
2593 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3547 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2594 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3548 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2595 3549
2596 if (exists $CFG{mlockall}) { 3550 if (exists $CFG{mlockall}) {
… …
2598 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3552 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2599 and die "WARNING: m(un)lockall failed: $!\n"; 3553 and die "WARNING: m(un)lockall failed: $!\n";
2600 }; 3554 };
2601 warn $@ if $@; 3555 warn $@ if $@;
2602 } 3556 }
3557
3558 trace "finished reloading resource files\n";
3559}
3560
3561sub pidfile() {
3562 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3563 or die "$PIDFILE: $!";
3564 flock $fh, &Fcntl::LOCK_EX
3565 or die "$PIDFILE: flock: $!";
3566 $fh
3567}
3568
3569# make sure only one server instance is running at any one time
3570sub atomic {
3571 my $fh = pidfile;
3572
3573 my $pid = <$fh>;
3574 kill 9, $pid if $pid > 0;
3575
3576 seek $fh, 0, 0;
3577 print $fh $$;
3578}
3579
3580sub main_loop {
3581 trace "EV::loop starting\n";
3582 if (1) {
3583 EV::loop;
3584 }
3585 trace "EV::loop returned\n";
3586 goto &main_loop unless $REALLY_UNLOOP;
2603} 3587}
2604 3588
2605sub main { 3589sub main {
3590 cf::init_globals; # initialise logging
3591
3592 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3593 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3594 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3595 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3596
3597 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3598
2606 # we must not ever block the main coroutine 3599 # we must not ever block the main coroutine
2607 local $Coro::idle = sub { 3600 local $Coro::idle = sub {
2608 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3601 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2609 (async { 3602 (async {
2610 Event::one_event; 3603 $Coro::current->{desc} = "IDLE BUG HANDLER";
3604 EV::loop EV::LOOP_ONESHOT;
2611 })->prio (Coro::PRIO_MAX); 3605 })->prio (Coro::PRIO_MAX);
2612 }; 3606 };
2613 3607
2614 cfg_load; 3608 evthread_start IO::AIO::poll_fileno;
3609
3610 cf::sync_job {
3611 cf::init_experience;
3612 cf::init_anim;
3613 cf::init_attackmess;
3614 cf::init_dynamic;
3615
3616 cf::load_settings;
3617 cf::load_materials;
3618
3619 reload_resources;
3620 reload_config;
2615 db_init; 3621 db_init;
3622
3623 cf::init_uuid;
3624 cf::init_signals;
3625 cf::init_skills;
3626
3627 cf::init_beforeplay;
3628
3629 atomic;
3630
2616 load_extensions; 3631 load_extensions;
2617 3632
2618 $TICK_WATCHER->start; 3633 utime time, time, $RUNTIMEFILE;
2619 Event::loop; 3634
3635 # no (long-running) fork's whatsoever before this point(!)
3636 use POSIX ();
3637 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3638
3639 (pop @POST_INIT)->(0) while @POST_INIT;
3640 };
3641
3642 cf::object::thawer::errors_are_fatal 0;
3643 info "parse errors in files are no longer fatal from this point on.\n";
3644
3645 main_loop;
2620} 3646}
2621 3647
2622############################################################################# 3648#############################################################################
2623# initialisation and cleanup 3649# initialisation and cleanup
2624 3650
2625# install some emergency cleanup handlers 3651# install some emergency cleanup handlers
2626BEGIN { 3652BEGIN {
3653 our %SIGWATCHER = ();
2627 for my $signal (qw(INT HUP TERM)) { 3654 for my $signal (qw(INT HUP TERM)) {
2628 Event->signal ( 3655 $SIGWATCHER{$signal} = AE::signal $signal, sub {
2629 reentrant => 0,
2630 data => WF_AUTOCANCEL,
2631 signal => $signal,
2632 prio => 0,
2633 cb => sub {
2634 cf::cleanup "SIG$signal"; 3656 cf::cleanup "SIG$signal";
2635 },
2636 ); 3657 };
3658 }
3659}
3660
3661sub write_runtime_sync {
3662 my $t0 = AE::time;
3663
3664 # first touch the runtime file to show we are still running:
3665 # the fsync below can take a very very long time.
3666
3667 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3668
3669 my $guard = cf::lock_acquire "write_runtime";
3670
3671 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3672 or return;
3673
3674 my $value = $cf::RUNTIME + 90 + 10;
3675 # 10 is the runtime save interval, for a monotonic clock
3676 # 60 allows for the watchdog to kill the server.
3677
3678 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3679 and return;
3680
3681 # always fsync - this file is important
3682 aio_fsync $fh
3683 and return;
3684
3685 # touch it again to show we are up-to-date
3686 aio_utime $fh, undef, undef;
3687
3688 close $fh
3689 or return;
3690
3691 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3692 and return;
3693
3694 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3695
2637 } 3696 1
3697}
3698
3699our $uuid_lock;
3700our $uuid_skip;
3701
3702sub write_uuid_sync($) {
3703 $uuid_skip ||= $_[0];
3704
3705 return if $uuid_lock;
3706 local $uuid_lock = 1;
3707
3708 my $uuid = "$LOCALDIR/uuid";
3709
3710 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3711 or return;
3712
3713 my $value = uuid_seq uuid_cur;
3714
3715 unless ($value) {
3716 info "cowardly refusing to write zero uuid value!\n";
3717 return;
3718 }
3719
3720 my $value = uuid_str $value + $uuid_skip;
3721 $uuid_skip = 0;
3722
3723 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3724 and return;
3725
3726 # always fsync - this file is important
3727 aio_fsync $fh
3728 and return;
3729
3730 close $fh
3731 or return;
3732
3733 aio_rename "$uuid~", $uuid
3734 and return;
3735
3736 trace "uuid file written ($value).\n";
3737
3738 1
3739
3740}
3741
3742sub write_uuid($$) {
3743 my ($skip, $sync) = @_;
3744
3745 $sync ? write_uuid_sync $skip
3746 : async { write_uuid_sync $skip };
2638} 3747}
2639 3748
2640sub emergency_save() { 3749sub emergency_save() {
2641 my $freeze_guard = cf::freeze_mainloop; 3750 my $freeze_guard = cf::freeze_mainloop;
2642 3751
2643 warn "enter emergency perl save\n"; 3752 info "emergency_perl_save: enter\n";
3753
3754 # this is a trade-off: we want to be very quick here, so
3755 # save all maps without fsync, and later call a global sync
3756 # (which in turn might be very very slow)
3757 local $USE_FSYNC = 0;
2644 3758
2645 cf::sync_job { 3759 cf::sync_job {
3760 cf::write_runtime_sync; # external watchdog should not bark
3761
2646 # use a peculiar iteration method to avoid tripping on perl 3762 # use a peculiar iteration method to avoid tripping on perl
2647 # refcount bugs in for. also avoids problems with players 3763 # refcount bugs in for. also avoids problems with players
2648 # and maps saved/destroyed asynchronously. 3764 # and maps saved/destroyed asynchronously.
2649 warn "begin emergency player save\n"; 3765 info "emergency_perl_save: begin player save\n";
2650 for my $login (keys %cf::PLAYER) { 3766 for my $login (keys %cf::PLAYER) {
2651 my $pl = $cf::PLAYER{$login} or next; 3767 my $pl = $cf::PLAYER{$login} or next;
2652 $pl->valid or next; 3768 $pl->valid or next;
3769 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2653 $pl->save; 3770 $pl->save;
2654 } 3771 }
2655 warn "end emergency player save\n"; 3772 info "emergency_perl_save: end player save\n";
2656 3773
2657 warn "begin emergency map save\n"; 3774 cf::write_runtime_sync; # external watchdog should not bark
3775
3776 info "emergency_perl_save: begin map save\n";
2658 for my $path (keys %cf::MAP) { 3777 for my $path (keys %cf::MAP) {
2659 my $map = $cf::MAP{$path} or next; 3778 my $map = $cf::MAP{$path} or next;
2660 $map->valid or next; 3779 $map->valid or next;
2661 $map->save; 3780 $map->save;
2662 } 3781 }
2663 warn "end emergency map save\n"; 3782 info "emergency_perl_save: end map save\n";
2664 3783
2665 warn "begin emergency database checkpoint\n"; 3784 cf::write_runtime_sync; # external watchdog should not bark
3785
3786 info "emergency_perl_save: begin database checkpoint\n";
2666 BDB::db_env_txn_checkpoint $DB_ENV; 3787 BDB::db_env_txn_checkpoint $DB_ENV;
2667 warn "end emergency database checkpoint\n"; 3788 info "emergency_perl_save: end database checkpoint\n";
3789
3790 info "emergency_perl_save: begin write uuid\n";
3791 write_uuid_sync 1;
3792 info "emergency_perl_save: end write uuid\n";
3793
3794 cf::write_runtime_sync; # external watchdog should not bark
3795
3796 trace "emergency_perl_save: syncing database to disk";
3797 BDB::db_env_txn_checkpoint $DB_ENV;
3798
3799 info "emergency_perl_save: starting sync\n";
3800 IO::AIO::aio_sync sub {
3801 info "emergency_perl_save: finished sync\n";
3802 };
3803
3804 cf::write_runtime_sync; # external watchdog should not bark
3805
3806 trace "emergency_perl_save: flushing outstanding aio requests";
3807 while (IO::AIO::nreqs || BDB::nreqs) {
3808 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3809 }
3810
3811 cf::write_runtime_sync; # external watchdog should not bark
2668 }; 3812 };
2669 3813
2670 warn "leave emergency perl save\n"; 3814 info "emergency_perl_save: leave\n";
2671} 3815}
2672 3816
2673sub post_cleanup { 3817sub post_cleanup {
2674 my ($make_core) = @_; 3818 my ($make_core) = @_;
2675 3819
3820 IO::AIO::flush;
3821
2676 warn Carp::longmess "post_cleanup backtrace" 3822 error Carp::longmess "post_cleanup backtrace"
2677 if $make_core; 3823 if $make_core;
3824
3825 my $fh = pidfile;
3826 unlink $PIDFILE if <$fh> == $$;
3827}
3828
3829# a safer delete_package, copied from Symbol
3830sub clear_package($) {
3831 my $pkg = shift;
3832
3833 # expand to full symbol table name if needed
3834 unless ($pkg =~ /^main::.*::$/) {
3835 $pkg = "main$pkg" if $pkg =~ /^::/;
3836 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3837 $pkg .= '::' unless $pkg =~ /::$/;
3838 }
3839
3840 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3841 my $stem_symtab = *{$stem}{HASH};
3842
3843 defined $stem_symtab and exists $stem_symtab->{$leaf}
3844 or return;
3845
3846 # clear all symbols
3847 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3848 for my $name (keys %$leaf_symtab) {
3849 _gv_clear *{"$pkg$name"};
3850# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3851 }
2678} 3852}
2679 3853
2680sub do_reload_perl() { 3854sub do_reload_perl() {
2681 # can/must only be called in main 3855 # can/must only be called in main
2682 if ($Coro::current != $Coro::main) { 3856 if (in_main) {
2683 warn "can only reload from main coroutine"; 3857 error "can only reload from main coroutine";
2684 return; 3858 return;
2685 } 3859 }
2686 3860
3861 return if $RELOAD++;
3862
3863 my $t1 = AE::time;
3864
3865 while ($RELOAD) {
2687 warn "reloading..."; 3866 info "reloading...";
2688 3867
2689 warn "entering sync_job"; 3868 trace "entering sync_job";
2690 3869
2691 cf::sync_job { 3870 cf::sync_job {
2692 cf::write_runtime; # external watchdog should not bark
2693 cf::emergency_save; 3871 cf::emergency_save;
2694 cf::write_runtime; # external watchdog should not bark
2695 3872
2696 warn "syncing database to disk";
2697 BDB::db_env_txn_checkpoint $DB_ENV;
2698
2699 # if anything goes wrong in here, we should simply crash as we already saved
2700
2701 warn "cancelling all WF_AUTOCANCEL watchers";
2702 for (Event::all_watchers) {
2703 $_->cancel if $_->data & WF_AUTOCANCEL;
2704 }
2705
2706 warn "flushing outstanding aio requests";
2707 for (;;) {
2708 BDB::flush;
2709 IO::AIO::flush;
2710 Coro::cede;
2711 last unless IO::AIO::nreqs || BDB::nreqs;
2712 warn "iterate...";
2713 }
2714
2715 ++$RELOAD;
2716
2717 warn "cancelling all extension coros"; 3873 trace "cancelling all extension coros";
2718 $_->cancel for values %EXT_CORO; 3874 $_->cancel for values %EXT_CORO;
2719 %EXT_CORO = (); 3875 %EXT_CORO = ();
2720 3876
2721 warn "removing commands"; 3877 trace "removing commands";
2722 %COMMAND = (); 3878 %COMMAND = ();
2723 3879
2724 warn "removing ext commands"; 3880 trace "removing ext/exti commands";
2725 %EXTCMD = (); 3881 %EXTCMD = ();
3882 %EXTICMD = ();
2726 3883
2727 warn "unloading/nuking all extensions"; 3884 trace "unloading/nuking all extensions";
2728 for my $pkg (@EXTS) { 3885 for my $pkg (@EXTS) {
2729 warn "... unloading $pkg"; 3886 trace "... unloading $pkg";
2730 3887
2731 if (my $cb = $pkg->can ("unload")) { 3888 if (my $cb = $pkg->can ("unload")) {
2732 eval { 3889 eval {
2733 $cb->($pkg); 3890 $cb->($pkg);
2734 1 3891 1
2735 } or warn "$pkg unloaded, but with errors: $@"; 3892 } or error "$pkg unloaded, but with errors: $@";
3893 }
3894
3895 trace "... clearing $pkg";
3896 clear_package $pkg;
2736 } 3897 }
2737 3898
2738 warn "... nuking $pkg";
2739 Symbol::delete_package $pkg;
2740 }
2741
2742 warn "unloading all perl modules loaded from $LIBDIR"; 3899 trace "unloading all perl modules loaded from $LIBDIR";
2743 while (my ($k, $v) = each %INC) { 3900 while (my ($k, $v) = each %INC) {
2744 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3901 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2745 3902
2746 warn "... unloading $k"; 3903 trace "... unloading $k";
2747 delete $INC{$k}; 3904 delete $INC{$k};
2748 3905
2749 $k =~ s/\.pm$//; 3906 $k =~ s/\.pm$//;
2750 $k =~ s/\//::/g; 3907 $k =~ s/\//::/g;
2751 3908
2752 if (my $cb = $k->can ("unload_module")) { 3909 if (my $cb = $k->can ("unload_module")) {
2753 $cb->(); 3910 $cb->();
3911 }
3912
3913 clear_package $k;
2754 } 3914 }
2755 3915
2756 Symbol::delete_package $k;
2757 }
2758
2759 warn "getting rid of safe::, as good as possible"; 3916 trace "getting rid of safe::, as good as possible";
2760 Symbol::delete_package "safe::$_" 3917 clear_package "safe::$_"
2761 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3918 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2762 3919
2763 warn "unloading cf.pm \"a bit\""; 3920 trace "unloading cf.pm \"a bit\"";
2764 delete $INC{"cf.pm"}; 3921 delete $INC{"cf.pm"};
2765 delete $INC{"cf/pod.pm"}; 3922 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2766 3923
2767 # don't, removes xs symbols, too, 3924 # don't, removes xs symbols, too,
2768 # and global variables created in xs 3925 # and global variables created in xs
2769 #Symbol::delete_package __PACKAGE__; 3926 #clear_package __PACKAGE__;
2770 3927
2771 warn "unload completed, starting to reload now"; 3928 info "unload completed, starting to reload now";
2772 3929
2773 warn "reloading cf.pm"; 3930 trace "reloading cf.pm";
2774 require cf; 3931 require cf;
2775 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3932 cf::_connect_to_perl_1;
2776 3933
2777 warn "loading config and database again"; 3934 trace "loading config and database again";
2778 cf::cfg_load; 3935 cf::reload_config;
2779 3936
2780 warn "loading extensions"; 3937 trace "loading extensions";
2781 cf::load_extensions; 3938 cf::load_extensions;
2782 3939
3940 if ($REATTACH_ON_RELOAD) {
2783 warn "reattaching attachments to objects/players"; 3941 trace "reattaching attachments to objects/players";
2784 _global_reattach; # objects, sockets 3942 _global_reattach; # objects, sockets
2785 warn "reattaching attachments to maps"; 3943 trace "reattaching attachments to maps";
2786 reattach $_ for values %MAP; 3944 reattach $_ for values %MAP;
2787 warn "reattaching attachments to players"; 3945 trace "reattaching attachments to players";
2788 reattach $_ for values %PLAYER; 3946 reattach $_ for values %PLAYER;
3947 }
2789 3948
3949 trace "running post_init jobs";
3950 (pop @POST_INIT)->(1) while @POST_INIT;
3951
2790 warn "leaving sync_job"; 3952 trace "leaving sync_job";
2791 3953
2792 1 3954 1
2793 } or do { 3955 } or do {
2794 warn $@; 3956 error $@;
2795 warn "error while reloading, exiting."; 3957 cf::cleanup "error while reloading, exiting.";
2796 exit 1; 3958 };
3959
3960 info "reloaded";
3961 --$RELOAD;
2797 }; 3962 }
2798 3963
2799 warn "reloaded"; 3964 $t1 = AE::time - $t1;
3965 info "reload completed in ${t1}s\n";
2800}; 3966};
2801 3967
2802our $RELOAD_WATCHER; # used only during reload 3968our $RELOAD_WATCHER; # used only during reload
2803 3969
2804sub reload_perl() { 3970sub reload_perl() {
2805 # doing reload synchronously and two reloads happen back-to-back, 3971 # doing reload synchronously and two reloads happen back-to-back,
2806 # coro crashes during coro_state_free->destroy here. 3972 # coro crashes during coro_state_free->destroy here.
2807 3973
2808 $RELOAD_WATCHER ||= Event->timer ( 3974 $RELOAD_WATCHER ||= cf::async {
2809 reentrant => 0, 3975 Coro::AIO::aio_wait cache_extensions;
2810 after => 0, 3976
2811 data => WF_AUTOCANCEL, 3977 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
2812 cb => sub {
2813 do_reload_perl; 3978 do_reload_perl;
2814 undef $RELOAD_WATCHER; 3979 undef $RELOAD_WATCHER;
2815 }, 3980 };
2816 ); 3981 };
2817} 3982}
2818 3983
2819register_command "reload" => sub { 3984register_command "reload" => sub {
2820 my ($who, $arg) = @_; 3985 my ($who, $arg) = @_;
2821 3986
2822 if ($who->flag (FLAG_WIZ)) { 3987 if ($who->flag (FLAG_WIZ)) {
2823 $who->message ("reloading server."); 3988 $who->message ("reloading server.");
3989 async {
3990 $Coro::current->{desc} = "perl_reload";
2824 async { reload_perl }; 3991 reload_perl;
3992 };
2825 } 3993 }
2826}; 3994};
2827 3995
2828unshift @INC, $LIBDIR; 3996unshift @INC, $LIBDIR;
2829 3997
… …
2831 3999
2832our @WAIT_FOR_TICK; 4000our @WAIT_FOR_TICK;
2833our @WAIT_FOR_TICK_BEGIN; 4001our @WAIT_FOR_TICK_BEGIN;
2834 4002
2835sub wait_for_tick { 4003sub wait_for_tick {
2836 return unless $TICK_WATCHER->is_active;
2837 return if $Coro::current == $Coro::main; 4004 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2838 4005
2839 my $signal = new Coro::Signal; 4006 my $signal = new Coro::Signal;
2840 push @WAIT_FOR_TICK, $signal; 4007 push @WAIT_FOR_TICK, $signal;
2841 $signal->wait; 4008 $signal->wait;
2842} 4009}
2843 4010
2844sub wait_for_tick_begin { 4011sub wait_for_tick_begin {
2845 return unless $TICK_WATCHER->is_active;
2846 return if $Coro::current == $Coro::main; 4012 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2847 4013
2848 my $signal = new Coro::Signal; 4014 my $signal = new Coro::Signal;
2849 push @WAIT_FOR_TICK_BEGIN, $signal; 4015 push @WAIT_FOR_TICK_BEGIN, $signal;
2850 $signal->wait; 4016 $signal->wait;
2851} 4017}
2852 4018
2853$TICK_WATCHER = Event->timer ( 4019sub tick {
2854 reentrant => 0,
2855 parked => 1,
2856 prio => 0,
2857 at => $NEXT_TICK || $TICK,
2858 data => WF_AUTOCANCEL,
2859 cb => sub {
2860 if ($Coro::current != $Coro::main) { 4020 if ($Coro::current != $Coro::main) {
2861 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 4021 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2862 unless ++$bug_warning > 10; 4022 unless ++$bug_warning > 10;
2863 return; 4023 return;
2864 } 4024 }
2865 4025
2866 $NOW = $tick_start = Event::time;
2867
2868 cf::server_tick; # one server iteration 4026 cf::server_tick; # one server iteration
2869 4027
2870 $RUNTIME += $TICK; 4028 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
2871 $NEXT_TICK += $TICK;
2872 4029
2873 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4030 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2874 $NEXT_RUNTIME_WRITE = $NOW + 10; 4031 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2875 Coro::async_pool { 4032 Coro::async_pool {
4033 $Coro::current->{desc} = "runtime saver";
2876 write_runtime 4034 write_runtime_sync
2877 or warn "ERROR: unable to write runtime file: $!"; 4035 or error "ERROR: unable to write runtime file: $!";
2878 };
2879 } 4036 };
4037 }
2880 4038
2881# my $AFTER = Event::time;
2882# warn $AFTER - $NOW;#d#
2883
2884 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4039 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2885 $sig->send; 4040 $sig->send;
2886 } 4041 }
2887 while (my $sig = shift @WAIT_FOR_TICK) { 4042 while (my $sig = shift @WAIT_FOR_TICK) {
2888 $sig->send; 4043 $sig->send;
2889 } 4044 }
2890 4045
2891 $NOW = Event::time; 4046 $LOAD = ($NOW - $TICK_START) / $TICK;
2892
2893 # if we are delayed by four ticks or more, skip them all
2894 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2895
2896 $TICK_WATCHER->at ($NEXT_TICK);
2897 $TICK_WATCHER->start;
2898
2899 $LOAD = ($NOW - $tick_start) / $TICK;
2900 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4047 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2901 4048
2902 _post_tick; 4049 if (0) {
2903 4050 if ($NEXT_TICK) {
2904 4051 my $jitter = $TICK_START - $NEXT_TICK;
4052 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4053 debug "jitter $JITTER\n";#d#
4054 }
2905 }, 4055 }
2906); 4056}
2907 4057
2908{ 4058{
2909 BDB::max_poll_time $TICK * 0.1; 4059 # configure BDB
2910 $BDB_POLL_WATCHER = Event->io ( 4060
2911 reentrant => 0,
2912 fd => BDB::poll_fileno,
2913 poll => 'r',
2914 prio => 0,
2915 data => WF_AUTOCANCEL,
2916 cb => \&BDB::poll_cb,
2917 );
2918 BDB::min_parallel 8; 4061 BDB::min_parallel 16;
2919 4062 BDB::max_poll_reqs $TICK * 0.1;
2920 BDB::set_sync_prepare { 4063 $AnyEvent::BDB::WATCHER->priority (1);
2921 my $status;
2922 my $current = $Coro::current;
2923 (
2924 sub {
2925 $status = $!;
2926 $current->ready; undef $current;
2927 },
2928 sub {
2929 Coro::schedule while defined $current;
2930 $! = $status;
2931 },
2932 )
2933 };
2934 4064
2935 unless ($DB_ENV) { 4065 unless ($DB_ENV) {
2936 $DB_ENV = BDB::db_env_create; 4066 $DB_ENV = BDB::db_env_create;
4067 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4068 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4069 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4070 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4071 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2937 4072
2938 cf::sync_job { 4073 cf::sync_job {
2939 eval { 4074 eval {
2940 BDB::db_env_open 4075 BDB::db_env_open
2941 $DB_ENV, 4076 $DB_ENV,
… …
2943 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 4078 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2944 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4079 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2945 0666; 4080 0666;
2946 4081
2947 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4082 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2948
2949 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2950 $DB_ENV->set_lk_detect;
2951 }; 4083 };
2952 4084
2953 cf::cleanup "db_env_open(db): $@" if $@; 4085 cf::cleanup "db_env_open(db): $@" if $@;
2954 }; 4086 };
2955 } 4087 }
4088
4089 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4090 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4091 };
4092 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4093 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4094 };
4095 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4096 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4097 };
2956} 4098}
2957 4099
2958{ 4100{
4101 # configure IO::AIO
4102
2959 IO::AIO::min_parallel 8; 4103 IO::AIO::min_parallel 8;
2960
2961 undef $Coro::AIO::WATCHER;
2962 IO::AIO::max_poll_time $TICK * 0.1; 4104 IO::AIO::max_poll_time $TICK * 0.1;
2963 $AIO_POLL_WATCHER = Event->io ( 4105 undef $AnyEvent::AIO::WATCHER;
2964 reentrant => 0,
2965 data => WF_AUTOCANCEL,
2966 fd => IO::AIO::poll_fileno,
2967 poll => 'r',
2968 prio => 6,
2969 cb => \&IO::AIO::poll_cb,
2970 );
2971} 4106}
2972 4107
2973my $_log_backtrace; 4108my $_log_backtrace;
2974 4109
2975sub _log_backtrace { 4110sub _log_backtrace {
… …
2978 $msg =~ s/\n//; 4113 $msg =~ s/\n//;
2979 4114
2980 # limit the # of concurrent backtraces 4115 # limit the # of concurrent backtraces
2981 if ($_log_backtrace < 2) { 4116 if ($_log_backtrace < 2) {
2982 ++$_log_backtrace; 4117 ++$_log_backtrace;
4118 my $perl_bt = Carp::longmess $msg;
2983 async { 4119 async {
4120 $Coro::current->{desc} = "abt $msg";
4121
2984 my @bt = fork_call { 4122 my @bt = fork_call {
2985 @addr = map { sprintf "%x", $_ } @addr; 4123 @addr = map { sprintf "%x", $_ } @addr;
2986 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 4124 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
2987 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 4125 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
2988 or die "addr2line: $!"; 4126 or die "addr2line: $!";
… …
2996 } 4134 }
2997 4135
2998 @funcs 4136 @funcs
2999 }; 4137 };
3000 4138
3001 LOG llevInfo, "[ABT] $msg\n"; 4139 LOG llevInfo, "[ABT] $perl_bt\n";
4140 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3002 LOG llevInfo, "[ABT] $_\n" for @bt; 4141 LOG llevInfo, "[ABT] $_\n" for @bt;
3003 --$_log_backtrace; 4142 --$_log_backtrace;
3004 }; 4143 };
3005 } else { 4144 } else {
3006 LOG llevInfo, "[ABT] $msg\n"; 4145 LOG llevInfo, "[ABT] $msg\n";
3007 LOG llevInfo, "[ABT] [suppressed]\n"; 4146 LOG llevInfo, "[ABT] [suppressed]\n";
3008 } 4147 }
3009} 4148}
3010 4149
3011# load additional modules 4150# load additional modules
3012use cf::pod; 4151require "cf/$_.pm" for @EXTRA_MODULES;
4152cf::_connect_to_perl_2;
3013 4153
3014END { cf::emergency_save } 4154END { cf::emergency_save }
3015 4155
30161 41561
3017 4157

Diff Legend

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