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.270 by root, Sat May 26 15:44:06 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 && $self->map->{path} ne "{link}"; 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) = @_;
1916 2646
… …
1933 ($x, $y) = (-1, -1) 2663 ($x, $y) = (-1, -1)
1934 unless (defined $x) && (defined $y); 2664 unless (defined $x) && (defined $y);
1935 2665
1936 # use -1 or undef as default coordinates, not 0, 0 2666 # use -1 or undef as default coordinates, not 0, 0
1937 ($x, $y) = ($map->enter_x, $map->enter_y) 2667 ($x, $y) = ($map->enter_x, $map->enter_y)
1938 if $x <=0 && $y <= 0; 2668 if $x <= 0 && $y <= 0;
1939 2669
1940 $map->load; 2670 $map->load;
1941 $map->load_diag; 2671 $map->load_neighbours;
1942 2672
1943 return unless $self->contr->active; 2673 return unless $self->contr->active;
1944 $self->activate_recursive;
1945 2674
1946 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2675 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1947 $self->enter_map ($map, $x, $y); 2676 if ($self->enter_map ($map, $x, $y)) {
1948} 2677 # entering was successful
2678 delete $self->{_link_recursion};
2679 # only activate afterwards, to support waiting in hooks
2680 $self->activate_recursive;
2681 }
1949 2682
2683}
2684
1950=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2685=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
1951 2686
1952Moves the player to the given map-path and coordinates by first freezing 2687Moves the player to the given map-path and coordinates by first freezing
1953her, loading and preparing them map, calling the provided $check callback 2688her, loading and preparing them map, calling the provided $check callback
1954that has to return the map if sucecssful, and then unfreezes the player on 2689that has to return the map if sucecssful, and then unfreezes the player on
1955the new (success) or old (failed) map position. 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 >>.
1956 2695
1957=cut 2696=cut
1958 2697
1959our $GOTOGEN; 2698our $GOTOGEN;
1960 2699
1961sub cf::object::player::goto { 2700sub cf::object::player::goto {
1962 my ($self, $path, $x, $y, $check) = @_; 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 }
1963 2708
1964 # do generation counting so two concurrent goto's will be executed in-order 2709 # do generation counting so two concurrent goto's will be executed in-order
1965 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2710 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1966 2711
1967 $self->enter_link; 2712 $self->enter_link;
1968 2713
1969 (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
1970 my $map = eval { 2736 my $map = eval {
1971 my $map = cf::map::find $path; 2737 my $map = defined $path ? cf::map::find $path : undef;
1972 2738
1973 if ($map) { 2739 if ($map) {
1974 $map = $map->customise_for ($self); 2740 $map = $map->customise_for ($self);
1975 $map = $check->($map) if $check && $map; 2741 $map = $check->($map, $x, $y, $self) if $check && $map;
1976 } else { 2742 } else {
1977 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2743 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
1978 } 2744 }
1979 2745
1980 $map 2746 $map
1981 }; 2747 };
1982 2748
… …
1987 2753
1988 if ($gen == $self->{_goto_generation}) { 2754 if ($gen == $self->{_goto_generation}) {
1989 delete $self->{_goto_generation}; 2755 delete $self->{_goto_generation};
1990 $self->leave_link ($map, $x, $y); 2756 $self->leave_link ($map, $x, $y);
1991 } 2757 }
2758
2759 $done->($self) if $done;
1992 })->prio (1); 2760 })->prio (1);
1993} 2761}
1994 2762
1995=item $player_object->enter_exit ($exit_object) 2763=item $player_object->enter_exit ($exit_object)
1996 2764
… …
2016} 2784}
2017 2785
2018sub prepare_random_map { 2786sub prepare_random_map {
2019 my ($exit) = @_; 2787 my ($exit) = @_;
2020 2788
2021 my $guard = cf::lock_acquire "exit_prepare:$exit";
2022
2023 # all this does is basically replace the /! path by 2789 # all this does is basically replace the /! path by
2024 # a new random map path (?random/...) with a seed 2790 # a new random map path (?random/...) with a seed
2025 # that depends on the exit object 2791 # that depends on the exit object
2026 2792
2027 my $rmp = parse_random_map_params $exit->msg; 2793 my $rmp = parse_random_map_params $exit->msg;
… …
2029 if ($exit->map) { 2795 if ($exit->map) {
2030 $rmp->{region} = $exit->region->name; 2796 $rmp->{region} = $exit->region->name;
2031 $rmp->{origin_map} = $exit->map->path; 2797 $rmp->{origin_map} = $exit->map->path;
2032 $rmp->{origin_x} = $exit->x; 2798 $rmp->{origin_x} = $exit->x;
2033 $rmp->{origin_y} = $exit->y; 2799 $rmp->{origin_y} = $exit->y;
2800
2801 $exit->map->touch;
2034 } 2802 }
2035 2803
2036 $rmp->{random_seed} ||= $exit->random_seed; 2804 $rmp->{random_seed} ||= $exit->random_seed;
2037 2805
2038 my $data = cf::to_json $rmp; 2806 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2039 my $md5 = Digest::MD5::md5_hex $data; 2807 my $md5 = Digest::MD5::md5_hex $data;
2040 my $meta = "$RANDOMDIR/$md5.meta"; 2808 my $meta = "$RANDOMDIR/$md5.meta";
2041 2809
2042 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2810 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2043 aio_write $fh, 0, (length $data), $data, 0; 2811 aio_write $fh, 0, (length $data), $data, 0;
2044 undef $fh; 2812 undef $fh;
2045 aio_rename "$meta~", $meta; 2813 aio_rename "$meta~", $meta;
2046 2814
2815 my $slaying = "?random/$md5";
2816
2817 if ($exit->valid) {
2047 $exit->slaying ("?random/$md5"); 2818 $exit->slaying ("?random/$md5");
2048 $exit->msg (undef); 2819 $exit->msg (undef);
2820 }
2049 } 2821 }
2050} 2822}
2051 2823
2052sub cf::object::player::enter_exit { 2824sub cf::object::player::enter_exit {
2053 my ($self, $exit) = @_; 2825 my ($self, $exit) = @_;
2054 2826
2055 return unless $self->type == cf::PLAYER; 2827 return unless $self->type == cf::PLAYER;
2056 2828
2057 if ($exit->slaying eq "/!") {
2058 #TODO: this should de-fi-ni-te-ly not be a sync-job
2059 # the problem is that $exit might not survive long enough
2060 # so it needs to be done right now, right here
2061 cf::sync_job { prepare_random_map $exit };
2062 }
2063
2064 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2065 my $hp = $exit->stats->hp;
2066 my $sp = $exit->stats->sp;
2067
2068 $self->enter_link; 2829 $self->enter_link;
2069 2830
2070 (async { 2831 (async {
2071 $self->deactivate_recursive; # just to be sure 2832 $Coro::current->{desc} = "enter_exit";
2833
2072 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
2073 $self->goto ($slaying, $hp, $sp); 2849 $self->goto ($map, $x, $y);
2074 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
2075 1; 2855 1
2076 }) { 2856 }) {
2077 $self->message ("Something went wrong deep within the crossfire server. " 2857 $self->message ("Something went wrong deep within the deliantra server. "
2078 . "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. "
2079 . "Please report this to the dungeon master!", 2859 . "Please report this to the dungeon master!",
2080 cf::NDI_UNIQUE | cf::NDI_RED); 2860 cf::NDI_UNIQUE | cf::NDI_RED);
2081 2861
2082 warn "ERROR in enter_exit: $@"; 2862 error "ERROR in enter_exit: $@";
2083 $self->leave_link; 2863 $self->leave_link;
2084 } 2864 }
2085 })->prio (1); 2865 })->prio (1);
2086} 2866}
2087 2867
… …
2101 2881
2102 utf8::encode $text; 2882 utf8::encode $text;
2103 $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);
2104} 2884}
2105 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
2106=item $client->ext_event ($type, %msg) 3073=item $client->ext_msg ($type, @msg)
2107 3074
2108Sends an exti event to the client. 3075Sends an ext event to the client.
2109 3076
2110=cut 3077=cut
2111 3078
2112sub cf::client::ext_event($$%) { 3079sub cf::client::ext_msg($$@) {
2113 my ($self, $type, %msg) = @_; 3080 my ($self, $type, @msg) = @_;
2114 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
2115 $msg{msgtype} = "event_$type"; 3085 push @msg, msgtype => "event_$type";
2116 $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 }
2117} 3106}
2118 3107
2119=item $success = $client->query ($flags, "text", \&cb) 3108=item $success = $client->query ($flags, "text", \&cb)
2120 3109
2121Queues a query to the client, calling the given callback with 3110Queues a query to the client, calling the given callback with
2122the 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>,
2123C<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>.
2124 3113
2125Queries 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
2126reliable at some point in the future. 3115become reliable at some point in the future.
2127 3116
2128=cut 3117=cut
2129 3118
2130sub cf::client::query { 3119sub cf::client::query {
2131 my ($self, $flags, $text, $cb) = @_; 3120 my ($self, $flags, $text, $cb) = @_;
… …
2139 utf8::encode $text; 3128 utf8::encode $text;
2140 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3129 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2141 3130
2142 $self->send_packet ($self->{query_queue}[0][0]) 3131 $self->send_packet ($self->{query_queue}[0][0])
2143 if @{ $self->{query_queue} } == 1; 3132 if @{ $self->{query_queue} } == 1;
3133
3134 1
2144} 3135}
2145 3136
2146cf::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 },
2147 on_reply => sub { 3143 on_reply => sub {
2148 my ($ns, $msg) = @_; 3144 my ($ns, $msg) = @_;
2149 3145
2150 # this weird shuffling is so that direct followup queries 3146 # this weird shuffling is so that direct followup queries
2151 # get handled first 3147 # get handled first
… …
2163 } else { 3159 } else {
2164 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3160 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2165 } 3161 }
2166 } 3162 }
2167 }, 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 },
2168); 3190);
2169 3191
2170=item $client->async (\&cb) 3192=item $client->async (\&cb)
2171 3193
2172Create a new coroutine, running the specified callback. The coroutine will 3194Create a new coroutine, running the specified callback. The coroutine will
… …
2188 3210
2189 $coro 3211 $coro
2190} 3212}
2191 3213
2192cf::client->attach ( 3214cf::client->attach (
2193 on_destroy => sub { 3215 on_client_destroy => sub {
2194 my ($ns) = @_; 3216 my ($ns) = @_;
2195 3217
2196 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3218 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2197 }, 3219 },
2198); 3220);
… …
2213our $safe = new Safe "safe"; 3235our $safe = new Safe "safe";
2214our $safe_hole = new Safe::Hole; 3236our $safe_hole = new Safe::Hole;
2215 3237
2216$SIG{FPE} = 'IGNORE'; 3238$SIG{FPE} = 'IGNORE';
2217 3239
2218$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));
2219 3245
2220# here we export the classes and methods available to script code 3246# here we export the classes and methods available to script code
2221 3247
2222=pod 3248=pod
2223 3249
2224The following functions and methods are available within a safe environment: 3250The following functions and methods are available within a safe environment:
2225 3251
2226 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
2227 cf::object::player player 3257 cf::object::player
2228 cf::player peaceful 3258 player
2229 cf::map trigger 3259
3260 cf::player
3261 peaceful
3262
3263 cf::map
3264 trigger
2230 3265
2231=cut 3266=cut
2232 3267
2233for ( 3268for (
2234 ["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)],
2235 ["cf::object::player" => qw(player)], 3272 ["cf::object::player" => qw(player)],
2236 ["cf::player" => qw(peaceful)], 3273 ["cf::player" => qw(peaceful send_msg)],
2237 ["cf::map" => qw(trigger)], 3274 ["cf::map" => qw(trigger)],
2238) { 3275) {
2239 no strict 'refs';
2240 my ($pkg, @funs) = @$_; 3276 my ($pkg, @funs) = @$_;
2241 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3277 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2242 for @funs; 3278 for @funs;
2243} 3279}
2244 3280
… …
2259 3295
2260 my $qcode = $code; 3296 my $qcode = $code;
2261 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3297 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2262 $qcode =~ s/\n/\\n/g; 3298 $qcode =~ s/\n/\\n/g;
2263 3299
3300 %vars = (_dummy => 0) unless %vars;
3301
3302 my @res;
2264 local $_; 3303 local $_;
2265 local @safe::cf::_safe_eval_args = values %vars;
2266 3304
2267 my $eval = 3305 my $eval =
2268 "do {\n" 3306 "do {\n"
2269 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3307 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2270 . "#line 0 \"{$qcode}\"\n" 3308 . "#line 0 \"{$qcode}\"\n"
2271 . $code 3309 . $code
2272 . "\n}" 3310 . "\n}"
2273 ; 3311 ;
2274 3312
3313 if ($CFG{safe_eval}) {
2275 sub_generation_inc; 3314 sub_generation_inc;
3315 local @safe::cf::_safe_eval_args = values %vars;
2276 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3316 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2277 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 }
2278 3322
2279 if ($@) { 3323 if ($@) {
2280 warn "$@"; 3324 warn "$@",
2281 warn "while executing safe code '$code'\n"; 3325 "while executing safe code '$code'\n",
2282 warn "with arguments " . (join " ", %vars) . "\n"; 3326 "with arguments " . (join " ", %vars) . "\n";
2283 } 3327 }
2284 3328
2285 wantarray ? @res : $res[0] 3329 wantarray ? @res : $res[0]
2286} 3330}
2287 3331
… …
2301=cut 3345=cut
2302 3346
2303sub register_script_function { 3347sub register_script_function {
2304 my ($fun, $cb) = @_; 3348 my ($fun, $cb) = @_;
2305 3349
2306 no strict 'refs'; 3350 $fun = "safe::$fun" if $CFG{safe_eval};
2307 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3351 *$fun = $safe_hole->wrap ($cb);
2308} 3352}
2309 3353
2310=back 3354=back
2311 3355
2312=cut 3356=cut
2313
2314#############################################################################
2315
2316=head2 EXTENSION DATABASE SUPPORT
2317
2318Crossfire maintains a very simple database for extension use. It can
2319currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2320convert to/from binary).
2321
2322The parameter C<$family> should best start with the name of the extension
2323using it, it should be unique.
2324
2325=over 4
2326
2327=item $value = cf::db_get $family => $key
2328
2329Returns a single value from the database.
2330
2331=item cf::db_put $family => $key => $value
2332
2333Stores the given C<$value> in the family.
2334
2335=cut
2336
2337our $DB;
2338
2339sub db_init {
2340 unless ($DB) {
2341 $DB = BDB::db_create $DB_ENV;
2342
2343 cf::sync_job {
2344 eval {
2345 $DB->set_flags (BDB::CHKSUM);
2346
2347 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2348 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2349 cf::cleanup "db_open(db): $!" if $!;
2350 };
2351 cf::cleanup "db_open(db): $@" if $@;
2352 };
2353 }
2354}
2355
2356sub db_get($$) {
2357 my $key = "$_[0]/$_[1]";
2358
2359 cf::sync_job {
2360 BDB::db_get $DB, undef, $key, my $data;
2361
2362 $! ? ()
2363 : $data
2364 }
2365}
2366
2367sub db_put($$$) {
2368 BDB::dbreq_pri 4;
2369 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2370}
2371
2372=item cf::cache $id => [$paths...], $processversion => $process
2373
2374Generic caching function that returns the value of the resource $id,
2375caching and regenerating as required.
2376
2377This function can block.
2378
2379=cut
2380
2381sub cache {
2382 my ($id, $src, $processversion, $process) = @_;
2383
2384 my $meta =
2385 join "\x00",
2386 $processversion,
2387 map {
2388 aio_stat $_
2389 and Carp::croak "$_: $!";
2390
2391 ($_, (stat _)[7,9])
2392 } @$src;
2393
2394 my $dbmeta = db_get cache => "$id/meta";
2395 if ($dbmeta ne $meta) {
2396 # changed, we may need to process
2397
2398 my @data;
2399 my $md5;
2400
2401 for (0 .. $#$src) {
2402 0 <= aio_load $src->[$_], $data[$_]
2403 or Carp::croak "$src->[$_]: $!";
2404 }
2405
2406 # if processing is expensive, check
2407 # checksum first
2408 if (1) {
2409 $md5 =
2410 join "\x00",
2411 $processversion,
2412 map {
2413 Coro::cede;
2414 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2415 } 0.. $#$src;
2416
2417
2418 my $dbmd5 = db_get cache => "$id/md5";
2419 if ($dbmd5 eq $md5) {
2420 db_put cache => "$id/meta", $meta;
2421
2422 return db_get cache => "$id/data";
2423 }
2424 }
2425
2426 my $t1 = Time::HiRes::time;
2427 my $data = $process->(\@data);
2428 my $t2 = Time::HiRes::time;
2429
2430 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2431
2432 db_put cache => "$id/data", $data;
2433 db_put cache => "$id/md5" , $md5;
2434 db_put cache => "$id/meta", $meta;
2435
2436 return $data;
2437 }
2438
2439 db_get cache => "$id/data"
2440}
2441
2442=item fork_call { }, $args
2443
2444Executes the given code block with the given arguments in a seperate
2445process, returning the results. Everything must be serialisable with
2446Coro::Storable. May, of course, block. Note that the executed sub may
2447never block itself or use any form of Event handling.
2448
2449=cut
2450
2451sub fork_call(&@) {
2452 my ($cb, @args) = @_;
2453
2454# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2455# or die "socketpair: $!";
2456 pipe my $fh1, my $fh2
2457 or die "pipe: $!";
2458
2459 if (my $pid = fork) {
2460 close $fh2;
2461
2462 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2463 $res = Coro::Storable::thaw $res;
2464
2465 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2466
2467 die $$res unless "ARRAY" eq ref $res;
2468
2469 return wantarray ? @$res : $res->[-1];
2470 } else {
2471 reset_signals;
2472 local $SIG{__WARN__};
2473 local $SIG{__DIE__};
2474 eval {
2475 close $fh1;
2476
2477 my @res = eval { $cb->(@args) };
2478 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2479 };
2480
2481 warn $@ if $@;
2482 _exit 0;
2483 }
2484}
2485
2486
2487 3357
2488############################################################################# 3358#############################################################################
2489# the server's init and main functions 3359# the server's init and main functions
2490 3360
2491sub load_facedata($) { 3361sub load_facedata($) {
2492 my ($path) = @_; 3362 my ($path) = @_;
2493 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
2494 warn "loading facedata from $path\n"; 3370 trace "loading facedata from $path\n";
2495 3371
2496 my $facedata; 3372 my $facedata;
2497 0 < aio_load $path, $facedata 3373 0 < aio_load $path, $facedata
2498 or die "$path: $!"; 3374 or die "$path: $!";
2499 3375
2500 $facedata = Coro::Storable::thaw $facedata; 3376 $facedata = Coro::Storable::thaw $facedata;
2501 3377
2502 $facedata->{version} == 2 3378 $facedata->{version} == 2
2503 or cf::cleanup "$path: version mismatch, cannot proceed."; 3379 or cf::cleanup "$path: version mismatch, cannot proceed.";
2504 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
2505 { 3390 {
2506 my $faces = $facedata->{faceinfo}; 3391 my $faces = $facedata->{faceinfo};
2507 3392
2508 while (my ($face, $info) = each %$faces) { 3393 while (my ($face, $info) = each %$faces) {
2509 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3394 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3395
2510 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3396 cf::face::set_visibility $idx, $info->{visibility};
3397 cf::face::set_magicmap $idx, $info->{magicmap};
2511 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3398 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2512 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3399 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2513 Coro::cede; 3400
3401 cf::cede_to_tick;
2514 } 3402 }
2515 3403
2516 while (my ($face, $info) = each %$faces) { 3404 while (my ($face, $info) = each %$faces) {
2517 next unless $info->{smooth}; 3405 next unless $info->{smooth};
3406
2518 my $idx = cf::face::find $face 3407 my $idx = cf::face::find $face
2519 or next; 3408 or next;
3409
2520 if (my $smooth = cf::face::find $info->{smooth}) { 3410 if (my $smooth = cf::face::find $info->{smooth}) {
3411 cf::face::set_smooth $idx, $smooth;
2521 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3412 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2522 } else { 3413 } else {
2523 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3414 error "smooth face '$info->{smooth}' not found for face '$face'";
2524 } 3415 }
2525 Coro::cede; 3416
3417 cf::cede_to_tick;
2526 } 3418 }
2527 } 3419 }
2528 3420
2529 { 3421 {
2530 my $anims = $facedata->{animinfo}; 3422 my $anims = $facedata->{animinfo};
2531 3423
2532 while (my ($anim, $info) = each %$anims) { 3424 while (my ($anim, $info) = each %$anims) {
2533 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3425 cf::anim::set $anim, $info->{frames}, $info->{facings};
2534 Coro::cede; 3426 cf::cede_to_tick;
2535 } 3427 }
2536 3428
2537 cf::anim::invalidate_all; # d'oh 3429 cf::anim::invalidate_all; # d'oh
2538 } 3430 }
2539 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
2540 1 3451 1
2541} 3452}
2542 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
2543sub 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
2544 load_resource_file "$MAPDIR/regions" 3477 load_resource_file "$MAPDIR/regions"
2545 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 }
2546} 3484}
2547 3485
2548sub reload_facedata { 3486sub reload_facedata {
2549 load_facedata "$DATADIR/facedata" 3487 load_facedata "$DATADIR/facedata"
2550 or die "unable to load facedata\n"; 3488 or die "unable to load facedata\n";
… …
2558sub reload_treasures { 3496sub reload_treasures {
2559 load_resource_file "$DATADIR/treasures" 3497 load_resource_file "$DATADIR/treasures"
2560 or die "unable to load treasurelists\n"; 3498 or die "unable to load treasurelists\n";
2561} 3499}
2562 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
2563sub reload_resources { 3524sub reload_resources {
2564 warn "reloading resource files...\n"; 3525 trace "reloading resource files...\n";
2565 3526
3527 reload_facedata;
3528 reload_sound;
3529 reload_archetypes;
2566 reload_regions; 3530 reload_regions;
2567 reload_facedata;
2568 reload_archetypes;
2569 reload_treasures; 3531 reload_treasures;
2570 3532
2571 warn "finished reloading resource files\n"; 3533 trace "finished reloading resource files\n";
2572} 3534}
2573 3535
2574sub init { 3536sub reload_config {
2575 reload_resources; 3537 trace "reloading config file...\n";
2576}
2577 3538
2578sub cfg_load {
2579 open my $fh, "<:utf8", "$CONFDIR/config" 3539 open my $fh, "<:utf8", "$CONFDIR/config"
2580 or return; 3540 or return;
2581 3541
2582 local $/; 3542 local $/;
2583 *CFG = YAML::Syck::Load <$fh>; 3543 *CFG = YAML::XS::Load scalar <$fh>;
2584 3544
2585 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3545 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
2586 3546
2587 $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};
2588 $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};
2589 3549
2590 if (exists $CFG{mlockall}) { 3550 if (exists $CFG{mlockall}) {
… …
2592 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3552 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2593 and die "WARNING: m(un)lockall failed: $!\n"; 3553 and die "WARNING: m(un)lockall failed: $!\n";
2594 }; 3554 };
2595 warn $@ if $@; 3555 warn $@ if $@;
2596 } 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;
2597} 3587}
2598 3588
2599sub 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
2600 # we must not ever block the main coroutine 3599 # we must not ever block the main coroutine
2601 local $Coro::idle = sub { 3600 local $Coro::idle = sub {
2602 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#
2603 (async { 3602 (async {
2604 Event::one_event; 3603 $Coro::current->{desc} = "IDLE BUG HANDLER";
3604 EV::loop EV::LOOP_ONESHOT;
2605 })->prio (Coro::PRIO_MAX); 3605 })->prio (Coro::PRIO_MAX);
2606 }; 3606 };
2607 3607
2608 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;
2609 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
2610 load_extensions; 3631 load_extensions;
2611 3632
2612 $TICK_WATCHER->start; 3633 utime time, time, $RUNTIMEFILE;
2613 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;
2614} 3646}
2615 3647
2616############################################################################# 3648#############################################################################
2617# initialisation and cleanup 3649# initialisation and cleanup
2618 3650
2619# install some emergency cleanup handlers 3651# install some emergency cleanup handlers
2620BEGIN { 3652BEGIN {
3653 our %SIGWATCHER = ();
2621 for my $signal (qw(INT HUP TERM)) { 3654 for my $signal (qw(INT HUP TERM)) {
2622 Event->signal ( 3655 $SIGWATCHER{$signal} = AE::signal $signal, sub {
2623 reentrant => 0,
2624 data => WF_AUTOCANCEL,
2625 signal => $signal,
2626 prio => 0,
2627 cb => sub {
2628 cf::cleanup "SIG$signal"; 3656 cf::cleanup "SIG$signal";
2629 },
2630 ); 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
2631 } 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 };
2632} 3747}
2633 3748
2634sub emergency_save() { 3749sub emergency_save() {
2635 my $freeze_guard = cf::freeze_mainloop; 3750 my $freeze_guard = cf::freeze_mainloop;
2636 3751
2637 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;
2638 3758
2639 cf::sync_job { 3759 cf::sync_job {
3760 cf::write_runtime_sync; # external watchdog should not bark
3761
2640 # use a peculiar iteration method to avoid tripping on perl 3762 # use a peculiar iteration method to avoid tripping on perl
2641 # refcount bugs in for. also avoids problems with players 3763 # refcount bugs in for. also avoids problems with players
2642 # and maps saved/destroyed asynchronously. 3764 # and maps saved/destroyed asynchronously.
2643 warn "begin emergency player save\n"; 3765 info "emergency_perl_save: begin player save\n";
2644 for my $login (keys %cf::PLAYER) { 3766 for my $login (keys %cf::PLAYER) {
2645 my $pl = $cf::PLAYER{$login} or next; 3767 my $pl = $cf::PLAYER{$login} or next;
2646 $pl->valid or next; 3768 $pl->valid or next;
3769 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2647 $pl->save; 3770 $pl->save;
2648 } 3771 }
2649 warn "end emergency player save\n"; 3772 info "emergency_perl_save: end player save\n";
2650 3773
2651 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";
2652 for my $path (keys %cf::MAP) { 3777 for my $path (keys %cf::MAP) {
2653 my $map = $cf::MAP{$path} or next; 3778 my $map = $cf::MAP{$path} or next;
2654 $map->valid or next; 3779 $map->valid or next;
2655 $map->save; 3780 $map->save;
2656 } 3781 }
2657 warn "end emergency map save\n"; 3782 info "emergency_perl_save: end map save\n";
2658 3783
2659 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";
2660 BDB::db_env_txn_checkpoint $DB_ENV; 3787 BDB::db_env_txn_checkpoint $DB_ENV;
2661 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
2662 }; 3812 };
2663 3813
2664 warn "leave emergency perl save\n"; 3814 info "emergency_perl_save: leave\n";
2665} 3815}
2666 3816
2667sub post_cleanup { 3817sub post_cleanup {
2668 my ($make_core) = @_; 3818 my ($make_core) = @_;
2669 3819
3820 IO::AIO::flush;
3821
2670 warn Carp::longmess "post_cleanup backtrace" 3822 error Carp::longmess "post_cleanup backtrace"
2671 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 }
2672} 3852}
2673 3853
2674sub do_reload_perl() { 3854sub do_reload_perl() {
2675 # can/must only be called in main 3855 # can/must only be called in main
2676 if ($Coro::current != $Coro::main) { 3856 if (in_main) {
2677 warn "can only reload from main coroutine"; 3857 error "can only reload from main coroutine";
2678 return; 3858 return;
2679 } 3859 }
2680 3860
3861 return if $RELOAD++;
3862
3863 my $t1 = AE::time;
3864
3865 while ($RELOAD) {
2681 warn "reloading..."; 3866 info "reloading...";
2682 3867
2683 warn "entering sync_job"; 3868 trace "entering sync_job";
2684 3869
2685 cf::sync_job { 3870 cf::sync_job {
2686 cf::write_runtime; # external watchdog should not bark
2687 cf::emergency_save; 3871 cf::emergency_save;
2688 cf::write_runtime; # external watchdog should not bark
2689 3872
2690 warn "syncing database to disk";
2691 BDB::db_env_txn_checkpoint $DB_ENV;
2692
2693 # if anything goes wrong in here, we should simply crash as we already saved
2694
2695 warn "cancelling all WF_AUTOCANCEL watchers";
2696 for (Event::all_watchers) {
2697 $_->cancel if $_->data & WF_AUTOCANCEL;
2698 }
2699
2700 warn "flushing outstanding aio requests";
2701 for (;;) {
2702 BDB::flush;
2703 IO::AIO::flush;
2704 Coro::cede;
2705 last unless IO::AIO::nreqs || BDB::nreqs;
2706 warn "iterate...";
2707 }
2708
2709 ++$RELOAD;
2710
2711 warn "cancelling all extension coros"; 3873 trace "cancelling all extension coros";
2712 $_->cancel for values %EXT_CORO; 3874 $_->cancel for values %EXT_CORO;
2713 %EXT_CORO = (); 3875 %EXT_CORO = ();
2714 3876
2715 warn "removing commands"; 3877 trace "removing commands";
2716 %COMMAND = (); 3878 %COMMAND = ();
2717 3879
2718 warn "removing ext commands"; 3880 trace "removing ext/exti commands";
2719 %EXTCMD = (); 3881 %EXTCMD = ();
3882 %EXTICMD = ();
2720 3883
2721 warn "unloading/nuking all extensions"; 3884 trace "unloading/nuking all extensions";
2722 for my $pkg (@EXTS) { 3885 for my $pkg (@EXTS) {
2723 warn "... unloading $pkg"; 3886 trace "... unloading $pkg";
2724 3887
2725 if (my $cb = $pkg->can ("unload")) { 3888 if (my $cb = $pkg->can ("unload")) {
2726 eval { 3889 eval {
2727 $cb->($pkg); 3890 $cb->($pkg);
2728 1 3891 1
2729 } 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;
2730 } 3897 }
2731 3898
2732 warn "... nuking $pkg";
2733 Symbol::delete_package $pkg;
2734 }
2735
2736 warn "unloading all perl modules loaded from $LIBDIR"; 3899 trace "unloading all perl modules loaded from $LIBDIR";
2737 while (my ($k, $v) = each %INC) { 3900 while (my ($k, $v) = each %INC) {
2738 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3901 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2739 3902
2740 warn "... unloading $k"; 3903 trace "... unloading $k";
2741 delete $INC{$k}; 3904 delete $INC{$k};
2742 3905
2743 $k =~ s/\.pm$//; 3906 $k =~ s/\.pm$//;
2744 $k =~ s/\//::/g; 3907 $k =~ s/\//::/g;
2745 3908
2746 if (my $cb = $k->can ("unload_module")) { 3909 if (my $cb = $k->can ("unload_module")) {
2747 $cb->(); 3910 $cb->();
3911 }
3912
3913 clear_package $k;
2748 } 3914 }
2749 3915
2750 Symbol::delete_package $k;
2751 }
2752
2753 warn "getting rid of safe::, as good as possible"; 3916 trace "getting rid of safe::, as good as possible";
2754 Symbol::delete_package "safe::$_" 3917 clear_package "safe::$_"
2755 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);
2756 3919
2757 warn "unloading cf.pm \"a bit\""; 3920 trace "unloading cf.pm \"a bit\"";
2758 delete $INC{"cf.pm"}; 3921 delete $INC{"cf.pm"};
2759 delete $INC{"cf/pod.pm"}; 3922 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2760 3923
2761 # don't, removes xs symbols, too, 3924 # don't, removes xs symbols, too,
2762 # and global variables created in xs 3925 # and global variables created in xs
2763 #Symbol::delete_package __PACKAGE__; 3926 #clear_package __PACKAGE__;
2764 3927
2765 warn "unload completed, starting to reload now"; 3928 info "unload completed, starting to reload now";
2766 3929
2767 warn "reloading cf.pm"; 3930 trace "reloading cf.pm";
2768 require cf; 3931 require cf;
2769 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3932 cf::_connect_to_perl_1;
2770 3933
2771 warn "loading config and database again"; 3934 trace "loading config and database again";
2772 cf::cfg_load; 3935 cf::reload_config;
2773 3936
2774 warn "loading extensions"; 3937 trace "loading extensions";
2775 cf::load_extensions; 3938 cf::load_extensions;
2776 3939
3940 if ($REATTACH_ON_RELOAD) {
2777 warn "reattaching attachments to objects/players"; 3941 trace "reattaching attachments to objects/players";
2778 _global_reattach; # objects, sockets 3942 _global_reattach; # objects, sockets
2779 warn "reattaching attachments to maps"; 3943 trace "reattaching attachments to maps";
2780 reattach $_ for values %MAP; 3944 reattach $_ for values %MAP;
2781 warn "reattaching attachments to players"; 3945 trace "reattaching attachments to players";
2782 reattach $_ for values %PLAYER; 3946 reattach $_ for values %PLAYER;
3947 }
2783 3948
3949 trace "running post_init jobs";
3950 (pop @POST_INIT)->(1) while @POST_INIT;
3951
2784 warn "leaving sync_job"; 3952 trace "leaving sync_job";
2785 3953
2786 1 3954 1
2787 } or do { 3955 } or do {
2788 warn $@; 3956 error $@;
2789 warn "error while reloading, exiting."; 3957 cf::cleanup "error while reloading, exiting.";
2790 exit 1; 3958 };
3959
3960 info "reloaded";
3961 --$RELOAD;
2791 }; 3962 }
2792 3963
2793 warn "reloaded"; 3964 $t1 = AE::time - $t1;
3965 info "reload completed in ${t1}s\n";
2794}; 3966};
2795 3967
2796our $RELOAD_WATCHER; # used only during reload 3968our $RELOAD_WATCHER; # used only during reload
2797 3969
2798sub reload_perl() { 3970sub reload_perl() {
2799 # doing reload synchronously and two reloads happen back-to-back, 3971 # doing reload synchronously and two reloads happen back-to-back,
2800 # coro crashes during coro_state_free->destroy here. 3972 # coro crashes during coro_state_free->destroy here.
2801 3973
2802 $RELOAD_WATCHER ||= Event->timer ( 3974 $RELOAD_WATCHER ||= cf::async {
2803 reentrant => 0, 3975 Coro::AIO::aio_wait cache_extensions;
2804 after => 0, 3976
2805 data => WF_AUTOCANCEL, 3977 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
2806 cb => sub {
2807 do_reload_perl; 3978 do_reload_perl;
2808 undef $RELOAD_WATCHER; 3979 undef $RELOAD_WATCHER;
2809 }, 3980 };
2810 ); 3981 };
2811} 3982}
2812 3983
2813register_command "reload" => sub { 3984register_command "reload" => sub {
2814 my ($who, $arg) = @_; 3985 my ($who, $arg) = @_;
2815 3986
2816 if ($who->flag (FLAG_WIZ)) { 3987 if ($who->flag (FLAG_WIZ)) {
2817 $who->message ("reloading server."); 3988 $who->message ("reloading server.");
3989 async {
3990 $Coro::current->{desc} = "perl_reload";
2818 async { reload_perl }; 3991 reload_perl;
3992 };
2819 } 3993 }
2820}; 3994};
2821 3995
2822unshift @INC, $LIBDIR; 3996unshift @INC, $LIBDIR;
2823 3997
… …
2825 3999
2826our @WAIT_FOR_TICK; 4000our @WAIT_FOR_TICK;
2827our @WAIT_FOR_TICK_BEGIN; 4001our @WAIT_FOR_TICK_BEGIN;
2828 4002
2829sub wait_for_tick { 4003sub wait_for_tick {
2830 return unless $TICK_WATCHER->is_active;
2831 return if $Coro::current == $Coro::main; 4004 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2832 4005
2833 my $signal = new Coro::Signal; 4006 my $signal = new Coro::Signal;
2834 push @WAIT_FOR_TICK, $signal; 4007 push @WAIT_FOR_TICK, $signal;
2835 $signal->wait; 4008 $signal->wait;
2836} 4009}
2837 4010
2838sub wait_for_tick_begin { 4011sub wait_for_tick_begin {
2839 return unless $TICK_WATCHER->is_active;
2840 return if $Coro::current == $Coro::main; 4012 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2841 4013
2842 my $signal = new Coro::Signal; 4014 my $signal = new Coro::Signal;
2843 push @WAIT_FOR_TICK_BEGIN, $signal; 4015 push @WAIT_FOR_TICK_BEGIN, $signal;
2844 $signal->wait; 4016 $signal->wait;
2845} 4017}
2846 4018
2847 my $min = 1e6;#d# 4019sub tick {
2848 my $avg = 10;
2849$TICK_WATCHER = Event->timer (
2850 reentrant => 0,
2851 parked => 1,
2852 prio => 0,
2853 at => $NEXT_TICK || $TICK,
2854 data => WF_AUTOCANCEL,
2855 cb => sub {
2856 if ($Coro::current != $Coro::main) { 4020 if ($Coro::current != $Coro::main) {
2857 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"
2858 unless ++$bug_warning > 10; 4022 unless ++$bug_warning > 10;
2859 return; 4023 return;
2860 } 4024 }
2861 4025
2862 $NOW = $tick_start = Event::time;
2863
2864 cf::server_tick; # one server iteration 4026 cf::server_tick; # one server iteration
2865 4027
2866 0 && sync_job {#d# 4028 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
2867 for(1..10) {
2868 my $t = Event::time;
2869 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2870 or die;
2871 4029
2872 $map->width (50); 4030 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2873 $map->height (50); 4031 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2874 $map->alloc; 4032 Coro::async_pool {
2875 $map->_load_objects ("/tmp/x.map", 1); 4033 $Coro::current->{desc} = "runtime saver";
2876 my $t = Event::time - $t; 4034 write_runtime_sync
2877 4035 or error "ERROR: unable to write runtime file: $!";
2878 #next unless $t < 0.0013;#d#
2879 if ($t < $min) {
2880 $min = $t;
2881 }
2882 $avg = $avg * 0.99 + $t * 0.01;
2883 }
2884 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2885 exit 0;
2886 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2887 }; 4036 };
4037 }
2888 4038
2889 $RUNTIME += $TICK;
2890 $NEXT_TICK += $TICK;
2891
2892 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2893 $NEXT_RUNTIME_WRITE = $NOW + 10;
2894 Coro::async_pool {
2895 write_runtime
2896 or warn "ERROR: unable to write runtime file: $!";
2897 };
2898 }
2899
2900# my $AFTER = Event::time;
2901# warn $AFTER - $NOW;#d#
2902
2903 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4039 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2904 $sig->send; 4040 $sig->send;
2905 } 4041 }
2906 while (my $sig = shift @WAIT_FOR_TICK) { 4042 while (my $sig = shift @WAIT_FOR_TICK) {
2907 $sig->send; 4043 $sig->send;
2908 } 4044 }
2909 4045
2910 $NOW = Event::time; 4046 $LOAD = ($NOW - $TICK_START) / $TICK;
2911
2912 # if we are delayed by four ticks or more, skip them all
2913 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2914
2915 $TICK_WATCHER->at ($NEXT_TICK);
2916 $TICK_WATCHER->start;
2917
2918 $LOAD = ($NOW - $tick_start) / $TICK;
2919 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4047 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2920 4048
2921 _post_tick; 4049 if (0) {
2922 4050 if ($NEXT_TICK) {
2923 4051 my $jitter = $TICK_START - $NEXT_TICK;
4052 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4053 debug "jitter $JITTER\n";#d#
4054 }
2924 }, 4055 }
2925); 4056}
2926 4057
2927{ 4058{
2928 BDB::max_poll_time $TICK * 0.1; 4059 # configure BDB
2929 $BDB_POLL_WATCHER = Event->io ( 4060
2930 reentrant => 0,
2931 fd => BDB::poll_fileno,
2932 poll => 'r',
2933 prio => 0,
2934 data => WF_AUTOCANCEL,
2935 cb => \&BDB::poll_cb,
2936 );
2937 BDB::min_parallel 8; 4061 BDB::min_parallel 16;
2938 4062 BDB::max_poll_reqs $TICK * 0.1;
2939 BDB::set_sync_prepare { 4063 $AnyEvent::BDB::WATCHER->priority (1);
2940 my $status;
2941 my $current = $Coro::current;
2942 (
2943 sub {
2944 $status = $!;
2945 $current->ready; undef $current;
2946 },
2947 sub {
2948 Coro::schedule while defined $current;
2949 $! = $status;
2950 },
2951 )
2952 };
2953 4064
2954 unless ($DB_ENV) { 4065 unless ($DB_ENV) {
2955 $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);
2956 4072
2957 cf::sync_job { 4073 cf::sync_job {
2958 eval { 4074 eval {
2959 BDB::db_env_open 4075 BDB::db_env_open
2960 $DB_ENV, 4076 $DB_ENV,
… …
2962 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
2963 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4079 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2964 0666; 4080 0666;
2965 4081
2966 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4082 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2967
2968 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2969 $DB_ENV->set_lk_detect;
2970 }; 4083 };
2971 4084
2972 cf::cleanup "db_env_open(db): $@" if $@; 4085 cf::cleanup "db_env_open(db): $@" if $@;
2973 }; 4086 };
2974 } 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 };
2975} 4098}
2976 4099
2977{ 4100{
4101 # configure IO::AIO
4102
2978 IO::AIO::min_parallel 8; 4103 IO::AIO::min_parallel 8;
2979
2980 undef $Coro::AIO::WATCHER;
2981 IO::AIO::max_poll_time $TICK * 0.1; 4104 IO::AIO::max_poll_time $TICK * 0.1;
2982 $AIO_POLL_WATCHER = Event->io ( 4105 undef $AnyEvent::AIO::WATCHER;
2983 reentrant => 0,
2984 data => WF_AUTOCANCEL,
2985 fd => IO::AIO::poll_fileno,
2986 poll => 'r',
2987 prio => 6,
2988 cb => \&IO::AIO::poll_cb,
2989 );
2990} 4106}
2991 4107
2992my $_log_backtrace; 4108my $_log_backtrace;
2993 4109
2994sub _log_backtrace { 4110sub _log_backtrace {
… …
2997 $msg =~ s/\n//; 4113 $msg =~ s/\n//;
2998 4114
2999 # limit the # of concurrent backtraces 4115 # limit the # of concurrent backtraces
3000 if ($_log_backtrace < 2) { 4116 if ($_log_backtrace < 2) {
3001 ++$_log_backtrace; 4117 ++$_log_backtrace;
4118 my $perl_bt = Carp::longmess $msg;
3002 async { 4119 async {
4120 $Coro::current->{desc} = "abt $msg";
4121
3003 my @bt = fork_call { 4122 my @bt = fork_call {
3004 @addr = map { sprintf "%x", $_ } @addr; 4123 @addr = map { sprintf "%x", $_ } @addr;
3005 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 4124 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3006 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 |"
3007 or die "addr2line: $!"; 4126 or die "addr2line: $!";
… …
3015 } 4134 }
3016 4135
3017 @funcs 4136 @funcs
3018 }; 4137 };
3019 4138
3020 LOG llevInfo, "[ABT] $msg\n"; 4139 LOG llevInfo, "[ABT] $perl_bt\n";
4140 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3021 LOG llevInfo, "[ABT] $_\n" for @bt; 4141 LOG llevInfo, "[ABT] $_\n" for @bt;
3022 --$_log_backtrace; 4142 --$_log_backtrace;
3023 }; 4143 };
3024 } else { 4144 } else {
3025 LOG llevInfo, "[ABT] $msg\n"; 4145 LOG llevInfo, "[ABT] $msg\n";
3026 LOG llevInfo, "[ABT] [suppressed]\n"; 4146 LOG llevInfo, "[ABT] [suppressed]\n";
3027 } 4147 }
3028} 4148}
3029 4149
3030# load additional modules 4150# load additional modules
3031use cf::pod; 4151require "cf/$_.pm" for @EXTRA_MODULES;
4152cf::_connect_to_perl_2;
3032 4153
3033END { cf::emergency_save } 4154END { cf::emergency_save }
3034 4155
30351 41561
3036 4157

Diff Legend

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