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.263 by root, Sat May 5 05:40:27 2007 UTC vs.
Revision 1.543 by root, Wed May 5 23:23:29 2010 UTC

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

Diff Legend

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