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.260 by root, Fri Apr 27 19:53:05 2007 UTC vs.
Revision 1.533 by root, Thu Apr 29 07:59:17 2010 UTC

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

Diff Legend

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