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.264 by root, Sun May 6 05:44:48 2007 UTC vs.
Revision 1.545 by root, Thu May 6 22:35:41 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 $runtime = "$LOCALDIR/runtime";
373 584
374 # first touch the runtime file to show we are still running: 585Executes the given code block with the given arguments in a seperate
375 # the fsync below can take a very very long time. 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.
376 589
377 warn "touching runtime...\n";#d# 590=cut
378 if (my $fh = aio_open $runtime, O_WRONLY, 0) { 591
379 utime undef, undef, $fh; 592sub fork_call(&@) {
593 my ($cb, @args) = @_;
594
595 # we seemingly have to make a local copy of the whole thing,
596 # otherwise perl prematurely frees the stuff :/
597 # TODO: investigate and fix (likely this will be rather laborious)
598
599 my @res = Coro::Util::fork_eval {
600 reset_signals;
601 &$cb
602 }, @args;
603
604 wantarray ? @res : $res[-1]
605}
606
607sub objinfo {
608 (
609 "counter value" => cf::object::object_count,
610 "objects created" => cf::object::create_count,
611 "objects destroyed" => cf::object::destroy_count,
612 "freelist size" => cf::object::free_count,
613 "allocated objects" => cf::object::objects_size,
614 "active objects" => cf::object::actives_size,
615 )
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 $!;
380 } 675 };
676 cf::cleanup "db_open(db): $@" if $@;
381 677
382 my $guard = cf::lock_acquire "write_runtime"; 678 $db
679}
383 680
384 warn "starting to write runtime...\n";#d# 681our $DB;
385 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
386 or return;
387 682
388 my $value = $cf::RUNTIME + 90 + 10; 683sub db_init {
389 # 10 is the runtime save interval, for a monotonic clock 684 $DB ||= db_table "db";
390 # 60 allows for the watchdog to kill the server. 685}
391 686
392 (aio_write $fh, 0, (length $value), $value, 0) <= 0 687sub db_get($$) {
393 and return; 688 my $key = "$_[0]/$_[1]";
394 689
395 # always fsync - this file is important 690 cf::error "db_get called from main context"
396 aio_fsync $fh 691 if $Coro::current == $Coro::main;
397 and return;
398 692
399 # touch it again to show we are up-to-date 693 BDB::db_get $DB, undef, $key, my $data;
400 utime undef, undef, $fh;
401 694
402 close $fh 695 $! ? ()
403 or return; 696 : $data
697}
404 698
405 aio_rename "$runtime~", $runtime 699sub db_put($$$) {
406 and return; 700 BDB::dbreq_pri 4;
701 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
702}
407 703
408 warn "... done writing runtime.\n";#d# 704=item cf::cache $id => [$paths...], $processversion => $process
409 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;
410 1 769 }
770
771 db_get cache => "$id/data"
411} 772}
412 773
413=item cf::datalog type => key => value, ... 774=item cf::datalog type => key => value, ...
414 775
415Log 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.
416 777
417=cut 778=cut
418 779
419sub datalog($@) { 780sub datalog($@) {
420 my ($type, %kv) = @_; 781 my ($type, %kv) = @_;
421 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 782 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
422} 783}
423 784
424=back 785=back
425 786
426=cut 787=cut
427 788
428############################################################################# 789#############################################################################
429 790
430=head2 ATTACHABLE OBJECTS 791=head2 ATTACHABLE OBJECTS
431 792
432Many 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
433attach callbacks/event handlers (a collection of which is called an "attachment") 794attach callbacks/event handlers (a collection of which is called an "attachment")
434to it. All such attachable objects support the following methods. 795to it. All such attachable objects support the following methods.
435 796
436In 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>
437C<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
438crossfire+). 799Deliantra).
439 800
440=over 4 801=over 4
441 802
442=item $attachable->attach ($attachment, key => $value...) 803=item $attachable->attach ($attachment, key => $value...)
443 804
… …
487=item cf::CLASS::attachment $name, ... 848=item cf::CLASS::attachment $name, ...
488 849
489Register an attachment by C<$name> through which attachable objects of the 850Register an attachment by C<$name> through which attachable objects of the
490given CLASS can refer to this attachment. 851given CLASS can refer to this attachment.
491 852
492Some classes such as crossfire maps and objects can specify attachments 853Some classes such as deliantra maps and objects can specify attachments
493that 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.
494 855
495These calls expect any number of the following handler/hook descriptions: 856These calls expect any number of the following handler/hook descriptions:
496 857
497=over 4 858=over 4
… …
606 $registry = $CB_TYPE[$object_type] ||= []; 967 $registry = $CB_TYPE[$object_type] ||= [];
607 968
608 } elsif ($type eq "subtype") { 969 } elsif ($type eq "subtype") {
609 defined $object_type or Carp::croak "subtype specified without type"; 970 defined $object_type or Carp::croak "subtype specified without type";
610 my $object_subtype = shift @arg; 971 my $object_subtype = shift @arg;
611 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 972 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
612 973
613 } elsif ($type eq "package") { 974 } elsif ($type eq "package") {
614 my $pkg = shift @arg; 975 my $pkg = shift @arg;
615 976
616 while (my ($name, $id) = each %cb_id) { 977 while (my ($name, $id) = each %cb_id) {
… …
621 982
622 } elsif (exists $cb_id{$type}) { 983 } elsif (exists $cb_id{$type}) {
623 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 984 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
624 985
625 } elsif (ref $type) { 986 } elsif (ref $type) {
626 warn "attaching objects not supported, ignoring.\n"; 987 error "attaching objects not supported, ignoring.\n";
627 988
628 } else { 989 } else {
629 shift @arg; 990 shift @arg;
630 warn "attach argument '$type' not supported, ignoring.\n"; 991 error "attach argument '$type' not supported, ignoring.\n";
631 } 992 }
632 } 993 }
633} 994}
634 995
635sub _object_attach { 996sub _object_attach {
… …
645 _attach $registry, $klass, @attach; 1006 _attach $registry, $klass, @attach;
646 } 1007 }
647 1008
648 $obj->{$name} = \%arg; 1009 $obj->{$name} = \%arg;
649 } else { 1010 } else {
650 warn "object uses attachment '$name' that is not available, postponing.\n"; 1011 info "object uses attachment '$name' which is not available, postponing.\n";
651 } 1012 }
652 1013
653 $obj->{_attachment}{$name} = undef; 1014 $obj->{_attachment}{$name} = undef;
654} 1015}
655 1016
… …
657 if (ref $_[0]) { 1018 if (ref $_[0]) {
658 _object_attach @_; 1019 _object_attach @_;
659 } else { 1020 } else {
660 _attach shift->_attach_registry, @_; 1021 _attach shift->_attach_registry, @_;
661 } 1022 }
1023 _recalc_want;
662}; 1024};
663 1025
664# all those should be optimised 1026# all those should be optimised
665sub cf::attachable::detach { 1027sub cf::attachable::detach {
666 my ($obj, $name) = @_; 1028 my ($obj, $name) = @_;
… …
669 delete $obj->{_attachment}{$name}; 1031 delete $obj->{_attachment}{$name};
670 reattach ($obj); 1032 reattach ($obj);
671 } else { 1033 } else {
672 Carp::croak "cannot, currently, detach class attachments"; 1034 Carp::croak "cannot, currently, detach class attachments";
673 } 1035 }
1036 _recalc_want;
674}; 1037};
675 1038
676sub cf::attachable::attached { 1039sub cf::attachable::attached {
677 my ($obj, $name) = @_; 1040 my ($obj, $name) = @_;
678 1041
… …
693 "; 1056 ";
694 die if $@; 1057 die if $@;
695} 1058}
696 1059
697our $override; 1060our $override;
698our @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?
699 1062
700sub override { 1063sub override {
701 $override = 1; 1064 $override = 1;
702 @invoke_results = (); 1065 @INVOKE_RESULTS = (@_);
703} 1066}
704 1067
705sub do_invoke { 1068sub do_invoke {
706 my $event = shift; 1069 my $event = shift;
707 my $callbacks = shift; 1070 my $callbacks = shift;
708 1071
709 @invoke_results = (); 1072 @INVOKE_RESULTS = ();
710 1073
711 local $override; 1074 local $override;
712 1075
713 for (@$callbacks) { 1076 for (@$callbacks) {
714 eval { &{$_->[1]} }; 1077 eval { &{$_->[1]} };
715 1078
716 if ($@) { 1079 if ($@) {
717 warn "$@";
718 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1080 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
719 override; 1081 override;
720 } 1082 }
721 1083
722 return 1 if $override; 1084 return 1 if $override;
723 } 1085 }
724 1086
725 0 1087 0
726} 1088}
727 1089
728=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1090=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
729 1091
730=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1092=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
731 1093
732Generate an object-specific event with the given arguments. 1094Generate an object-specific event with the given arguments.
733 1095
734This 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
735removed 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
736results (if you must, access C<@cf::invoke_results> directly). 1098results (if you must, access C<@cf::INVOKE_RESULTS> directly).
737 1099
738=back 1100=back
739 1101
740=cut 1102=cut
741 1103
742############################################################################# 1104#############################################################################
743# 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}
744 1148
745sub reattach { 1149sub reattach {
746 # basically do the same as instantiate, without calling instantiate 1150 # basically do the same as instantiate, without calling instantiate
747 my ($obj) = @_; 1151 my ($obj) = @_;
748 1152
1153 # no longer needed after getting rid of delete_package?
749 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
750 1155
751 my $registry = $obj->registry; 1156 my $registry = $obj->registry;
752 1157
753 @$registry = (); 1158 @$registry = ();
754 1159
… …
759 for (@$attach) { 1164 for (@$attach) {
760 my ($klass, @attach) = @$_; 1165 my ($klass, @attach) = @$_;
761 _attach $registry, $klass, @attach; 1166 _attach $registry, $klass, @attach;
762 } 1167 }
763 } else { 1168 } else {
764 warn "object uses attachment '$name' that is not available, postponing.\n"; 1169 info "object uses attachment '$name' that is not available, postponing.\n";
765 } 1170 }
766 } 1171 }
767} 1172}
768 1173
769cf::attachable->attach ( 1174cf::attachable->attach (
770 prio => -1000000, 1175 prio => -1000000,
771 on_instantiate => sub { 1176 on_instantiate => sub {
772 my ($obj, $data) = @_; 1177 my ($obj, $data) = @_;
773 1178
774 $data = from_json $data; 1179 $data = decode_json $data;
775 1180
776 for (@$data) { 1181 for (@$data) {
777 my ($name, $args) = @$_; 1182 my ($name, $args) = @$_;
778 1183
779 $obj->attach ($name, %{$args || {} }); 1184 $obj->attach ($name, %{$args || {} });
… …
795sub object_freezer_save { 1200sub object_freezer_save {
796 my ($filename, $rdata, $objs) = @_; 1201 my ($filename, $rdata, $objs) = @_;
797 1202
798 sync_job { 1203 sync_job {
799 if (length $$rdata) { 1204 if (length $$rdata) {
1205 utf8::decode (my $decname = $filename);
800 warn sprintf "saving %s (%d,%d)\n", 1206 trace sprintf "saving %s (%d,%d)\n",
801 $filename, length $$rdata, scalar @$objs; 1207 $decname, length $$rdata, scalar @$objs
1208 if $VERBOSE_IO;
802 1209
803 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1210 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
804 chmod SAVE_MODE, $fh; 1211 aio_chmod $fh, SAVE_MODE;
805 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1212 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
806 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 }
807 close $fh; 1217 aio_close $fh;
808 1218
809 if (@$objs) { 1219 if (@$objs) {
810 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) {
811 chmod SAVE_MODE, $fh; 1221 aio_chmod $fh, SAVE_MODE;
812 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1222 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
813 aio_write $fh, 0, (length $data), $data, 0; 1223 aio_write $fh, 0, (length $data), $data, 0;
814 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 }
815 close $fh; 1228 aio_close $fh;
816 aio_rename "$filename.pst~", "$filename.pst"; 1229 aio_rename "$filename.pst~", "$filename.pst";
817 } 1230 }
818 } else { 1231 } else {
819 aio_unlink "$filename.pst"; 1232 aio_unlink "$filename.pst";
820 } 1233 }
821 1234
822 aio_rename "$filename~", $filename; 1235 aio_rename "$filename~", $filename;
1236
1237 $filename =~ s%/[^/]+$%%;
1238 aio_pathsync $filename if $cf::USE_FSYNC;
823 } else { 1239 } else {
824 warn "FATAL: $filename~: $!\n"; 1240 error "unable to save objects: $filename~: $!\n";
825 } 1241 }
826 } else { 1242 } else {
827 aio_unlink $filename; 1243 aio_unlink $filename;
828 aio_unlink "$filename.pst"; 1244 aio_unlink "$filename.pst";
829 } 1245 }
830 } 1246 };
831} 1247}
832 1248
833sub object_freezer_as_string { 1249sub object_freezer_as_string {
834 my ($rdata, $objs) = @_; 1250 my ($rdata, $objs) = @_;
835 1251
… …
847 or return; 1263 or return;
848 1264
849 unless (aio_stat "$filename.pst") { 1265 unless (aio_stat "$filename.pst") {
850 (aio_load "$filename.pst", $av) >= 0 1266 (aio_load "$filename.pst", $av) >= 0
851 or return; 1267 or return;
1268
852 $av = eval { (Storable::thaw $av)->{objs} }; 1269 my $st = eval { Coro::Storable::thaw $av };
1270 $av = $st->{objs};
853 } 1271 }
854 1272
1273 utf8::decode (my $decname = $filename);
855 warn sprintf "loading %s (%d)\n", 1274 trace sprintf "loading %s (%d,%d)\n",
856 $filename, length $data, scalar @{$av || []};#d# 1275 $decname, length $data, scalar @{$av || []}
1276 if $VERBOSE_IO;
1277
857 return ($data, $av); 1278 ($data, $av)
858} 1279}
1280
1281=head2 COMMAND CALLBACKS
1282
1283=over 4
1284
1285=cut
859 1286
860############################################################################# 1287#############################################################################
861# command handling &c 1288# command handling &c
862 1289
863=item cf::register_command $name => \&callback($ob,$args); 1290=item cf::register_command $name => \&callback($ob,$args);
… …
876 push @{ $COMMAND{$name} }, [$caller, $cb]; 1303 push @{ $COMMAND{$name} }, [$caller, $cb];
877} 1304}
878 1305
879=item cf::register_extcmd $name => \&callback($pl,$packet); 1306=item cf::register_extcmd $name => \&callback($pl,$packet);
880 1307
881Register 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.
882 1313
883If 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
884called. 1315called.
885 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
886=cut 1328=cut
887 1329
888sub register_extcmd { 1330sub register_extcmd {
889 my ($name, $cb) = @_; 1331 my ($name, $cb) = @_;
890 1332
891 $EXTCMD{$name} = $cb; 1333 $EXTCMD{$name} = $cb;
892} 1334}
893 1335
1336sub register_exticmd {
1337 my ($name, $cb) = @_;
1338
1339 $EXTICMD{$name} = $cb;
1340}
1341
1342use File::Glob ();
1343
894cf::player->attach ( 1344cf::player->attach (
895 on_command => sub { 1345 on_unknown_command => sub {
896 my ($pl, $name, $params) = @_; 1346 my ($pl, $name, $params) = @_;
897 1347
898 my $cb = $COMMAND{$name} 1348 my $cb = $COMMAND{$name}
899 or return; 1349 or return;
900 1350
… …
905 cf::override; 1355 cf::override;
906 }, 1356 },
907 on_extcmd => sub { 1357 on_extcmd => sub {
908 my ($pl, $buf) = @_; 1358 my ($pl, $buf) = @_;
909 1359
910 my $msg = eval { from_json $buf }; 1360 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
911 1361
912 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
913 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1370 if (my $cb = $EXTCMD{$type}) {
914 if (my %reply = $cb->($pl, $msg)) { 1371 @reply = $cb->($pl, @payload);
915 $pl->ext_reply ($msg->{msgid}, %reply);
916 }
917 } 1372 }
1373
1374 $pl->ext_reply ($reply, @reply)
1375 if $reply;
1376
918 } else { 1377 } else {
919 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1378 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
920 } 1379 }
921 1380
922 cf::override; 1381 cf::override;
923 }, 1382 },
924); 1383);
925 1384
1385# "readahead" all extensions
926sub load_extension { 1386sub cache_extensions {
927 my ($path) = @_; 1387 my $grp = IO::AIO::aio_group;
928 1388
929 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1389 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
930 my $base = $1; 1390 for (grep /\.ext$/, @{$_[0]}) {
931 my $pkg = $1; 1391 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
932 $pkg =~ s/[^[:word:]]/_/g;
933 $pkg = "ext::$pkg";
934
935 warn "... loading '$path' into '$pkg'\n";
936
937 open my $fh, "<:utf8", $path
938 or die "$path: $!";
939
940 my $source =
941 "package $pkg; use strict; use utf8;\n"
942 . "#line 1 \"$path\"\n{\n"
943 . (do { local $/; <$fh> })
944 . "\n};\n1";
945
946 unless (eval $source) {
947 my $msg = $@ ? "$path: $@\n"
948 : "extension disabled.\n";
949 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
950 warn $@;
951 warn "mandatory extension failed to load, exiting.\n";
952 exit 1;
953 } 1392 }
954 die $@;
955 } 1393 };
956 1394
957 push @EXTS, $pkg; 1395 $grp
958} 1396}
959 1397
960sub load_extensions { 1398sub load_extensions {
1399 info "loading extensions...";
1400
1401 cf::sync_job {
1402 my %todo;
1403
961 for my $ext (<$LIBDIR/*.ext>) { 1404 for my $path (<$LIBDIR/*.ext>) {
962 next unless -r $ext; 1405 next unless -r $path;
963 eval { 1406
964 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 }
965 1 1470 }
966 } 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 }
967 } 1481 };
968} 1482}
969 1483
970############################################################################# 1484#############################################################################
971 1485
1486=back
1487
972=head2 CORE EXTENSIONS 1488=head2 CORE EXTENSIONS
973 1489
974Functions and methods that extend core crossfire objects. 1490Functions and methods that extend core deliantra objects.
975 1491
976=cut 1492=cut
977 1493
978package cf::player; 1494package cf::player;
979 1495
980use Coro::AIO; 1496use Coro::AIO;
981 1497
982=head3 cf::player 1498=head3 cf::player
983 1499
984=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}
985 1515
986=item cf::player::find $login 1516=item cf::player::find $login
987 1517
988Returns the given player object, loading it if necessary (might block). 1518Returns the given player object, loading it if necessary (might block).
989 1519
… …
1008 1538
1009sub exists($) { 1539sub exists($) {
1010 my ($login) = @_; 1540 my ($login) = @_;
1011 1541
1012 $cf::PLAYER{$login} 1542 $cf::PLAYER{$login}
1013 or cf::sync_job { !aio_stat path $login } 1543 or !aio_stat path $login
1014} 1544}
1015 1545
1016sub find($) { 1546sub find($) {
1017 return $cf::PLAYER{$_[0]} || do { 1547 return $cf::PLAYER{$_[0]} || do {
1018 my $login = $_[0]; 1548 my $login = $_[0];
… …
1025 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1555 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1026 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1556 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1027 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1557 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1028 aio_unlink +(playerdir $login) . "/$login.pl"; 1558 aio_unlink +(playerdir $login) . "/$login.pl";
1029 1559
1030 my $pl = load_pl path $login 1560 my $f = new_from_file cf::object::thawer path $login
1031 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;
1032 $cf::PLAYER{$login} = $pl 1568 $cf::PLAYER{$login} = $pl
1033 } 1569 }
1034 } 1570 }
1035} 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);
1036 1585
1037sub save($) { 1586sub save($) {
1038 my ($pl) = @_; 1587 my ($pl) = @_;
1039 1588
1040 return if $pl->{deny_save}; 1589 return if $pl->{deny_save};
… …
1045 return if $pl->{deny_save}; 1594 return if $pl->{deny_save};
1046 1595
1047 aio_mkdir playerdir $pl, 0770; 1596 aio_mkdir playerdir $pl, 0770;
1048 $pl->{last_save} = $cf::RUNTIME; 1597 $pl->{last_save} = $cf::RUNTIME;
1049 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
1050 $pl->save_pl ($path); 1604 $pl->save_pl ($path);
1051 Coro::cede; 1605 cf::cede_to_tick;
1052} 1606}
1053 1607
1054sub new($) { 1608sub new($) {
1055 my ($login) = @_; 1609 my ($login) = @_;
1056 1610
… …
1062 $cf::PLAYER{$login} = $self; 1616 $cf::PLAYER{$login} = $self;
1063 1617
1064 $self 1618 $self
1065} 1619}
1066 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
1067=item $pl->quit_character 1631=item $pl->quit_character
1068 1632
1069Nukes the player without looking back. If logged in, the connection will 1633Nukes the player without looking back. If logged in, the connection will
1070be destroyed. May block for a long time. 1634be destroyed. May block for a long time.
1071 1635
… …
1075 my ($pl) = @_; 1639 my ($pl) = @_;
1076 1640
1077 my $name = $pl->ob->name; 1641 my $name = $pl->ob->name;
1078 1642
1079 $pl->{deny_save} = 1; 1643 $pl->{deny_save} = 1;
1080 $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
1081 1645
1082 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1646 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1083 $pl->deactivate; 1647 $pl->deactivate;
1648 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1084 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1649 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1085 $pl->ns->destroy if $pl->ns; 1650 $pl->ns->destroy if $pl->ns;
1086 1651
1087 my $path = playerdir $pl; 1652 my $path = playerdir $pl;
1088 my $temp = "$path~$cf::RUNTIME~deleting~"; 1653 my $temp = "$path~$cf::RUNTIME~deleting~";
… …
1124 or return []; 1689 or return [];
1125 1690
1126 my @logins; 1691 my @logins;
1127 1692
1128 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") {
1129 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1699 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1130 aio_read $fh, 0, 512, my $buf, 0 or next; 1700 aio_read $fh, 0, 512, my $buf, 0 or next;
1131 $buf !~ /^password -------------$/m or next; # official not-valid tag 1701 $buf !~ /^password -------------$/m or next; # official not-valid tag
1702 }
1132 1703
1133 utf8::decode $login; 1704 utf8::decode $login;
1134 push @logins, $login; 1705 push @logins, $login;
1135 } 1706 }
1136 1707
1137 \@logins 1708 \@logins
1138} 1709}
1139 1710
1140=item $player->maps 1711=item $player->maps
1712
1713=item cf::player::maps $login
1141 1714
1142Returns an arrayref of map paths that are private for this 1715Returns an arrayref of map paths that are private for this
1143player. May block. 1716player. May block.
1144 1717
1145=cut 1718=cut
… …
1163 } 1736 }
1164 1737
1165 \@paths 1738 \@paths
1166} 1739}
1167 1740
1741=item $protocol_xml = $player->expand_cfpod ($cfpod)
1742
1743Expand deliantra pod fragments into protocol xml.
1744
1168=item $player->ext_reply ($msgid, %msg) 1745=item $player->ext_reply ($msgid, @msg)
1169 1746
1170Sends an ext reply to the player. 1747Sends an ext reply to the player.
1171 1748
1172=cut 1749=cut
1173 1750
1174sub ext_reply($$%) { 1751sub ext_reply($$@) {
1175 my ($self, $id, %msg) = @_; 1752 my ($self, $id, @msg) = @_;
1176 1753
1177 $msg{msgid} = $id; 1754 $self->ns->ext_reply ($id, @msg)
1178
1179 $self->send ("ext " . cf::to_json \%msg);
1180} 1755}
1181 1756
1182=item $player->ext_event ($type, %msg) 1757=item $player->ext_msg ($type, @msg)
1183 1758
1184Sends an ext event to the client. 1759Sends an ext event to the client.
1185 1760
1186=cut 1761=cut
1187 1762
1188sub ext_event($$%) { 1763sub ext_msg($$@) {
1189 my ($self, $type, %msg) = @_; 1764 my ($self, $type, @msg) = @_;
1190 1765
1191 $self->ns->ext_event ($type, %msg); 1766 $self->ns->ext_msg ($type, @msg);
1192} 1767}
1193 1768
1194=head3 cf::region 1769=head3 cf::region
1195 1770
1196=over 4 1771=over 4
… …
1199 1774
1200package cf::region; 1775package cf::region;
1201 1776
1202=item cf::region::find_by_path $path 1777=item cf::region::find_by_path $path
1203 1778
1204Tries 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.
1205 1780
1206=cut 1781=cut
1207 1782
1208sub find_by_path($) { 1783sub find_by_path($) {
1209 my ($path) = @_; 1784 my ($path) = @_;
1210 1785
1786 $path =~ s/^~[^\/]*//; # skip ~login
1787
1211 my ($match, $specificity); 1788 my ($match, $specificity);
1212 1789
1213 for my $region (list) { 1790 for my $region (list) {
1214 if ($region->match && $path =~ $region->match) { 1791 if ($region->{match} && $path =~ $region->{match}) {
1215 ($match, $specificity) = ($region, $region->specificity) 1792 ($match, $specificity) = ($region, $region->specificity)
1216 if $region->specificity > $specificity; 1793 if $region->specificity > $specificity;
1217 } 1794 }
1218 } 1795 }
1219 1796
… …
1240our $MAX_RESET = 3600; 1817our $MAX_RESET = 3600;
1241our $DEFAULT_RESET = 3000; 1818our $DEFAULT_RESET = 3000;
1242 1819
1243sub generate_random_map { 1820sub generate_random_map {
1244 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
1245 # mit "rum" bekleckern, nicht 1825 # mit "rum" bekleckern, nicht
1246 $self->_create_random_map ( 1826 $self->_create_random_map (
1247 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1827 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1248 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1828 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1249 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1829 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1250 $rmp->{exit_on_final_map}, 1830 $rmp->{exit_on_final_map},
1251 $rmp->{xsize}, $rmp->{ysize}, 1831 $rmp->{xsize}, $rmp->{ysize},
1252 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1832 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1253 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1833 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
… …
1268 1848
1269sub register { 1849sub register {
1270 my (undef, $regex, $prio) = @_; 1850 my (undef, $regex, $prio) = @_;
1271 my $pkg = caller; 1851 my $pkg = caller;
1272 1852
1273 no strict;
1274 push @{"$pkg\::ISA"}, __PACKAGE__; 1853 push @{"$pkg\::ISA"}, __PACKAGE__;
1275 1854
1276 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1855 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1277} 1856}
1278 1857
1279# also paths starting with '/' 1858# also paths starting with '/'
1280$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1859$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1281 1860
1282sub thawer_merge { 1861sub thawer_merge {
1283 my ($self, $merge) = @_; 1862 my ($self, $merge) = @_;
1284 1863
1285 # we have to keep some variables in memory intact 1864 # we have to keep some variables in memory intact
1286 local $self->{path}; 1865 local $self->{path};
1287 local $self->{load_path}; 1866 local $self->{load_path};
1288 local $self->{deny_save};
1289 local $self->{deny_reset};
1290 1867
1291 $self->SUPER::thawer_merge ($merge); 1868 $self->SUPER::thawer_merge ($merge);
1292} 1869}
1293 1870
1294sub normalise { 1871sub normalise {
1295 my ($path, $base) = @_; 1872 my ($path, $base) = @_;
1296 1873
1297 $path = "$path"; # make sure its a string 1874 $path = "$path"; # make sure it's a string
1298 1875
1299 $path =~ s/\.map$//; 1876 $path =~ s/\.map$//;
1300 1877
1301 # map plan: 1878 # map plan:
1302 # 1879 #
… …
1341 $self->init; # pass $1 etc. 1918 $self->init; # pass $1 etc.
1342 return $self; 1919 return $self;
1343 } 1920 }
1344 } 1921 }
1345 1922
1346 Carp::carp "unable to resolve path '$path' (base '$base')."; 1923 Carp::cluck "unable to resolve path '$path' (base '$base')";
1347 () 1924 ()
1348} 1925}
1349 1926
1350sub init { 1927sub init {
1351 my ($self) = @_; 1928 my ($self) = @_;
… …
1373 1950
1374# the temporary/swap location 1951# the temporary/swap location
1375sub save_path { 1952sub save_path {
1376 my ($self) = @_; 1953 my ($self) = @_;
1377 1954
1378 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1955 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1379 "$TMPDIR/$path.map" 1956 "$TMPDIR/$path.map"
1380} 1957}
1381 1958
1382# the unique path, undef == no special unique path 1959# the unique path, undef == no special unique path
1383sub uniq_path { 1960sub uniq_path {
1384 my ($self) = @_; 1961 my ($self) = @_;
1385 1962
1386 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1963 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1387 "$UNIQUEDIR/$path" 1964 "$UNIQUEDIR/$path"
1388} 1965}
1389 1966
1390# and all this just because we cannot iterate over 1967sub decay_objects {
1391# all maps in C++...
1392sub change_all_map_light {
1393 my ($change) = @_; 1968 my ($self) = @_;
1394 1969
1395 $_->change_map_light ($change) 1970 return if $self->{deny_reset};
1396 for grep $_->outdoor, values %cf::MAP; 1971
1972 $self->do_decay_objects;
1397} 1973}
1398 1974
1399sub unlink_save { 1975sub unlink_save {
1400 my ($self) = @_; 1976 my ($self) = @_;
1401 1977
… …
1406 1982
1407sub load_header_from($) { 1983sub load_header_from($) {
1408 my ($self, $path) = @_; 1984 my ($self, $path) = @_;
1409 1985
1410 utf8::encode $path; 1986 utf8::encode $path;
1411 #aio_open $path, O_RDONLY, 0 1987 my $f = new_from_file cf::object::thawer $path
1412 # or return;
1413
1414 $self->_load_header ($path)
1415 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;
1416 1995
1417 $self->{load_path} = $path; 1996 $self->{load_path} = $path;
1418 1997
1419 1 1998 1
1420} 1999}
… …
1459 $self->load_header_orig 2038 $self->load_header_orig
1460 or return; 2039 or return;
1461 $self->prepare_orig; 2040 $self->prepare_orig;
1462 } 2041 }
1463 2042
2043 $self->{deny_reset} = 1
2044 if $self->no_reset;
2045
1464 $self->default_region (cf::region::find_by_path $self->{path}) 2046 $self->default_region (cf::region::find_by_path $self->{path})
1465 unless $self->default_region; 2047 unless $self->default_region;
1466 2048
1467 1 2049 1
1468} 2050}
1469 2051
1470sub find; 2052sub find;
1471sub find { 2053sub find {
1472 my ($path, $origin) = @_; 2054 my ($path, $origin) = @_;
1473 2055
2056 cf::cede_to_tick;
2057
1474 $path = normalise $path, $origin && $origin->path; 2058 $path = normalise $path, $origin && $origin->path;
1475 2059
2060 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1476 cf::lock_wait "map_find:$path"; 2061 my $guard2 = cf::lock_acquire "map_find:$path";
1477 2062
1478 $cf::MAP{$path} || do { 2063 $cf::MAP{$path} || do {
1479 my $guard = cf::lock_acquire "map_find:$path";
1480 my $map = new_from_path cf::map $path 2064 my $map = new_from_path cf::map $path
1481 or return; 2065 or return;
1482 2066
1483 $map->{last_save} = $cf::RUNTIME; 2067 $map->{last_save} = $cf::RUNTIME;
1484 2068
1485 $map->load_header 2069 $map->load_header
1486 or return; 2070 or return;
1487 2071
1488 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 2072 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1489 # doing this can freeze the server in a sync job, obviously 2073 # doing this can freeze the server in a sync job, obviously
1490 #$cf::WAIT_FOR_TICK->wait; 2074 #$cf::WAIT_FOR_TICK->wait;
2075 undef $guard2;
2076 undef $guard1;
1491 $map->reset; 2077 $map->reset;
1492 undef $guard;
1493 return find $path; 2078 return find $path;
1494 } 2079 }
1495 2080
1496 $cf::MAP{$path} = $map 2081 $cf::MAP{$path} = $map
1497 } 2082 }
1498} 2083}
1499 2084
1500sub pre_load { } 2085sub pre_load { }
1501sub post_load { } 2086#sub post_load { } # XS
1502 2087
1503sub load { 2088sub load {
1504 my ($self) = @_; 2089 my ($self) = @_;
1505 2090
1506 local $self->{deny_reset} = 1; # loading can take a long time 2091 local $self->{deny_reset} = 1; # loading can take a long time
1507 2092
1508 my $path = $self->{path}; 2093 my $path = $self->{path};
1509 2094
1510 { 2095 {
1511 my $guard = cf::lock_acquire "map_load:$path"; 2096 my $guard = cf::lock_acquire "map_data:$path";
1512 2097
2098 return unless $self->valid;
1513 return if $self->in_memory != cf::MAP_SWAPPED; 2099 return unless $self->in_memory == cf::MAP_SWAPPED;
1514 2100
1515 $self->in_memory (cf::MAP_LOADING); 2101 $self->in_memory (cf::MAP_LOADING);
1516 2102
1517 $self->alloc; 2103 $self->alloc;
1518 2104
1519 $self->pre_load; 2105 $self->pre_load;
1520 Coro::cede; 2106 cf::cede_to_tick;
1521 2107
2108 my $f = new_from_file cf::object::thawer $self->{load_path};
2109 $f->skip_block;
1522 $self->_load_objects ($self->{load_path}, 1) 2110 $self->_load_objects ($f)
1523 or return; 2111 or return;
1524 2112
1525 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2113 $self->post_load_original
1526 if delete $self->{load_original}; 2114 if delete $self->{load_original};
1527 2115
1528 if (my $uniq = $self->uniq_path) { 2116 if (my $uniq = $self->uniq_path) {
1529 utf8::encode $uniq; 2117 utf8::encode $uniq;
1530 if (aio_open $uniq, O_RDONLY, 0) { 2118 unless (aio_stat $uniq) {
2119 if (my $f = new_from_file cf::object::thawer $uniq) {
1531 $self->clear_unique_items; 2120 $self->clear_unique_items;
1532 $self->_load_objects ($uniq, 0); 2121 $self->_load_objects ($f);
2122 $f->resolve_delayed_derefs;
2123 }
1533 } 2124 }
1534 } 2125 }
1535 2126
1536 Coro::cede; 2127 $f->resolve_delayed_derefs;
2128
2129 cf::cede_to_tick;
1537 # now do the right thing for maps 2130 # now do the right thing for maps
1538 $self->link_multipart_objects; 2131 $self->link_multipart_objects;
1539 $self->difficulty ($self->estimate_difficulty) 2132 $self->difficulty ($self->estimate_difficulty)
1540 unless $self->difficulty; 2133 unless $self->difficulty;
1541 Coro::cede; 2134 cf::cede_to_tick;
1542 2135
1543 unless ($self->{deny_activate}) { 2136 unless ($self->{deny_activate}) {
1544 $self->decay_objects; 2137 $self->decay_objects;
1545 $self->fix_auto_apply; 2138 $self->fix_auto_apply;
1546 $self->update_buttons; 2139 $self->update_buttons;
1547 Coro::cede; 2140 cf::cede_to_tick;
1548 $self->set_darkness_map;
1549 Coro::cede;
1550 $self->activate; 2141 $self->activate;
1551 } 2142 }
1552 2143
2144 $self->{last_save} = $cf::RUNTIME;
2145 $self->last_access ($cf::RUNTIME);
2146
1553 $self->in_memory (cf::MAP_IN_MEMORY); 2147 $self->in_memory (cf::MAP_ACTIVE);
1554 } 2148 }
1555 2149
1556 $self->post_load; 2150 $self->post_load;
1557} 2151}
1558 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
1559sub customise_for { 2156sub customise_for {
1560 my ($self, $ob) = @_; 2157 my ($self, $ob) = @_;
1561 2158
1562 return find "~" . $ob->name . "/" . $self->{path} 2159 return find "~" . $ob->name . "/" . $self->{path}
1563 if $self->per_player; 2160 if $self->per_player;
1564 2161
2162# return find "?party/" . $ob->name . "/" . $self->{path}
2163# if $self->per_party;
2164
1565 $self 2165 $self
1566} 2166}
1567 2167
1568# 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
1569sub load_diag { 2169sub load_neighbours {
1570 my ($map) = @_; 2170 my ($map) = @_;
1571 2171
1572 my @diag; # diagonal neighbours 2172 my @neigh; # diagonal neighbours
1573 2173
1574 for (0 .. 3) { 2174 for (0 .. 3) {
1575 my $neigh = $map->tile_path ($_) 2175 my $neigh = $map->tile_path ($_)
1576 or next; 2176 or next;
1577 $neigh = find $neigh, $map 2177 $neigh = find $neigh, $map
1578 or next; 2178 or next;
1579 $neigh->load; 2179 $neigh->load;
1580 2180
2181 # now find the diagonal neighbours
2182 push @neigh,
1581 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2183 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1582 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2184 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1583 } 2185 }
1584 2186
1585 for (@diag) { 2187 for (grep defined $_->[0], @neigh) {
2188 my ($path, $origin) = @$_;
1586 my $neigh = find @$_ 2189 my $neigh = find $path, $origin
1587 or next; 2190 or next;
1588 $neigh->load; 2191 $neigh->load;
1589 } 2192 }
1590} 2193}
1591 2194
1592sub find_sync { 2195sub find_sync {
1593 my ($path, $origin) = @_; 2196 my ($path, $origin) = @_;
1594 2197
1595 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
1596} 2202}
1597 2203
1598sub do_load_sync { 2204sub do_load_sync {
1599 my ($map) = @_; 2205 my ($map) = @_;
1600 2206
1601 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;
1602} 2211}
1603 2212
1604our %MAP_PREFETCH; 2213our %MAP_PREFETCH;
1605our $MAP_PREFETCHER = undef; 2214our $MAP_PREFETCHER = undef;
1606 2215
1607sub find_async { 2216sub find_async {
1608 my ($path, $origin) = @_; 2217 my ($path, $origin, $load) = @_;
1609 2218
1610 $path = normalise $path, $origin && $origin->{path}; 2219 $path = normalise $path, $origin && $origin->{path};
1611 2220
1612 if (my $map = $cf::MAP{$path}) { 2221 if (my $map = $cf::MAP{$path}) {
1613 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2222 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1614 } 2223 }
1615 2224
1616 undef $MAP_PREFETCH{$path}; 2225 $MAP_PREFETCH{$path} |= $load;
2226
1617 $MAP_PREFETCHER ||= cf::async { 2227 $MAP_PREFETCHER ||= cf::async {
2228 $Coro::current->{desc} = "map prefetcher";
2229
1618 while (%MAP_PREFETCH) { 2230 while (%MAP_PREFETCH) {
1619 for my $path (keys %MAP_PREFETCH) { 2231 while (my ($k, $v) = each %MAP_PREFETCH) {
1620 my $map = find $path 2232 if (my $map = find $k) {
1621 or next;
1622 $map->load; 2233 $map->load if $v;
2234 }
1623 2235
1624 delete $MAP_PREFETCH{$path}; 2236 delete $MAP_PREFETCH{$k};
1625 } 2237 }
1626 } 2238 }
1627 undef $MAP_PREFETCHER; 2239 undef $MAP_PREFETCHER;
1628 }; 2240 };
1629 $MAP_PREFETCHER->prio (6); 2241 $MAP_PREFETCHER->prio (6);
1630 2242
1631 () 2243 ()
1632} 2244}
1633 2245
2246# common code, used by both ->save and ->swapout
1634sub save { 2247sub _save {
1635 my ($self) = @_; 2248 my ($self) = @_;
1636
1637 my $lock = cf::lock_acquire "map_data:" . $self->path;
1638 2249
1639 $self->{last_save} = $cf::RUNTIME; 2250 $self->{last_save} = $cf::RUNTIME;
1640 2251
1641 return unless $self->dirty; 2252 return unless $self->dirty;
1642 2253
… …
1648 return if $self->{deny_save}; 2259 return if $self->{deny_save};
1649 2260
1650 local $self->{last_access} = $self->last_access;#d# 2261 local $self->{last_access} = $self->last_access;#d#
1651 2262
1652 cf::async { 2263 cf::async {
2264 $Coro::current->{desc} = "map player save";
1653 $_->contr->save for $self->players; 2265 $_->contr->save for $self->players;
1654 }; 2266 };
2267
2268 cf::get_slot 0.02;
1655 2269
1656 if ($uniq) { 2270 if ($uniq) {
1657 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2271 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1658 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2272 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1659 } else { 2273 } else {
1660 $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);
1661 } 2275 }
1662} 2276}
1663 2277
2278sub save {
2279 my ($self) = @_;
2280
2281 my $lock = cf::lock_acquire "map_data:$self->{path}";
2282
2283 $self->_save;
2284}
2285
1664sub swap_out { 2286sub swap_out {
1665 my ($self) = @_; 2287 my ($self) = @_;
1666 2288
1667 # save first because save cedes
1668 $self->save;
1669
1670 my $lock = cf::lock_acquire "map_data:" . $self->path; 2289 my $lock = cf::lock_acquire "map_data:$self->{path}";
1671 2290
2291 return if $self->in_memory != cf::MAP_ACTIVE;
2292 return if $self->{deny_save};
1672 return if $self->players; 2293 return if $self->players;
1673 return if $self->in_memory != cf::MAP_IN_MEMORY;
1674 return if $self->{deny_save};
1675 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
1676 $self->clear; 2304 $self->clear;
1677 $self->in_memory (cf::MAP_SWAPPED);
1678} 2305}
1679 2306
1680sub reset_at { 2307sub reset_at {
1681 my ($self) = @_; 2308 my ($self) = @_;
1682 2309
1683 # TODO: safety, remove and allow resettable per-player maps 2310 # TODO: safety, remove and allow resettable per-player maps
1684 return 1e99 if $self->isa ("ext::map_per_player");#d#
1685 return 1e99 if $self->{deny_reset}; 2311 return 1e99 if $self->{deny_reset};
1686 2312
1687 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2313 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1688 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;
1689 2315
… …
1700 my ($self) = @_; 2326 my ($self) = @_;
1701 2327
1702 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2328 my $lock = cf::lock_acquire "map_data:$self->{path}";
1703 2329
1704 return if $self->players; 2330 return if $self->players;
1705 return if $self->isa ("ext::map_per_player");#d#
1706 2331
1707 warn "resetting map ", $self->path;#d# 2332 cf::trace "resetting map ", $self->path, "\n";
1708 2333
1709 $self->in_memory (cf::MAP_SWAPPED); 2334 $self->in_memory (cf::MAP_SWAPPED);
1710 2335
1711 # need to save uniques path 2336 # need to save uniques path
1712 unless ($self->{deny_save}) { 2337 unless ($self->{deny_save}) {
… …
1716 if $uniq; 2341 if $uniq;
1717 } 2342 }
1718 2343
1719 delete $cf::MAP{$self->path}; 2344 delete $cf::MAP{$self->path};
1720 2345
2346 $self->deactivate;
2347 $_->clear_links_to ($self) for values %cf::MAP;
1721 $self->clear; 2348 $self->clear;
1722
1723 $_->clear_links_to ($self) for values %cf::MAP;
1724 2349
1725 $self->unlink_save; 2350 $self->unlink_save;
1726 $self->destroy; 2351 $self->destroy;
1727} 2352}
1728 2353
1729my $nuke_counter = "aaaa"; 2354my $nuke_counter = "aaaa";
1730 2355
1731sub nuke { 2356sub nuke {
1732 my ($self) = @_; 2357 my ($self) = @_;
1733 2358
2359 {
2360 my $lock = cf::lock_acquire "map_data:$self->{path}";
2361
1734 delete $cf::MAP{$self->path}; 2362 delete $cf::MAP{$self->path};
1735 2363
1736 $self->unlink_save; 2364 $self->unlink_save;
1737 2365
1738 bless $self, "cf::map"; 2366 bless $self, "cf::map::wrap";
1739 delete $self->{deny_reset}; 2367 delete $self->{deny_reset};
1740 $self->{deny_save} = 1; 2368 $self->{deny_save} = 1;
1741 $self->reset_timeout (1); 2369 $self->reset_timeout (1);
1742 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2370 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1743 2371
1744 $cf::MAP{$self->path} = $self; 2372 $cf::MAP{$self->path} = $self;
2373 }
1745 2374
1746 $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 ]
1747} 2412}
1748 2413
1749=item cf::map::unique_maps 2414=item cf::map::unique_maps
1750 2415
1751Returns an arrayref of paths of all shared maps that have 2416Returns an arrayref of paths of all shared maps that have
1752instantiated unique items. May block. 2417instantiated unique items. May block.
1753 2418
1754=cut 2419=cut
1755 2420
1756sub unique_maps() { 2421sub unique_maps() {
1757 my $files = aio_readdir $UNIQUEDIR 2422 [
1758 or return; 2423 map {
1759
1760 my @paths;
1761
1762 for (@$files) {
1763 utf8::decode $_; 2424 utf8::decode $_;
1764 next if /\.pst$/; 2425 s/\.map$//; # TODO future compatibility hack
1765 next unless /^$PATH_SEP/o; 2426 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1766 2427 ? ()
1767 push @paths, cf::map::normalise $_; 2428 : normalise $_
2429 } @{ aio_readdir $UNIQUEDIR or [] }
1768 } 2430 ]
1769
1770 \@paths
1771} 2431}
1772 2432
1773package 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}
1774 2464
1775=back 2465=back
1776 2466
1777=head3 cf::object 2467=head3 cf::object
1778 2468
… …
1782 2472
1783=over 4 2473=over 4
1784 2474
1785=item $ob->inv_recursive 2475=item $ob->inv_recursive
1786 2476
1787Returns 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.
1788 2479
1789=cut 2480=cut
1790 2481
1791sub inv_recursive_; 2482sub inv_recursive_;
1792sub inv_recursive_ { 2483sub inv_recursive_ {
… …
1795 2486
1796sub inv_recursive { 2487sub inv_recursive {
1797 inv_recursive_ inv $_[0] 2488 inv_recursive_ inv $_[0]
1798} 2489}
1799 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
1800package cf; 2519package cf;
1801 2520
1802=back 2521=back
1803 2522
1804=head3 cf::object::player 2523=head3 cf::object::player
… …
1810Sends 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>
1811can 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
1812dialogue with the given NPC character. 2531dialogue with the given NPC character.
1813 2532
1814=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};
1815 2548
1816# rough implementation of a future "reply" method that works 2549# rough implementation of a future "reply" method that works
1817# with dialog boxes. 2550# with dialog boxes.
1818#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
1819sub cf::object::player::reply($$$;$) { 2552sub cf::object::player::reply($$$;$) {
… …
1821 2554
1822 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2555 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1823 2556
1824 if ($self->{record_replies}) { 2557 if ($self->{record_replies}) {
1825 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2558 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2559
1826 } 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 {
1827 $msg = $npc->name . " says: $msg" if $npc; 2568 $msg = $npc->name . " says: $msg" if $npc;
1828 $self->message ($msg, $flags); 2569 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2570 }
1829 } 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 (@_);
1830} 2582}
1831 2583
1832=item $player_object->may ("access") 2584=item $player_object->may ("access")
1833 2585
1834Returns wether the given player is authorized to access resource "access" 2586Returns wether the given player is authorized to access resource "access"
… …
1847 2599
1848=item $player_object->enter_link 2600=item $player_object->enter_link
1849 2601
1850Freezes 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}>).
1851 2603
1852The 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.
1853I<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.
1854 2608
1855Will never block. 2609Will never block.
1856 2610
1857=item $player_object->leave_link ($map, $x, $y) 2611=item $player_object->leave_link ($map, $x, $y)
1858 2612
… …
1878sub cf::object::player::enter_link { 2632sub cf::object::player::enter_link {
1879 my ($self) = @_; 2633 my ($self) = @_;
1880 2634
1881 $self->deactivate_recursive; 2635 $self->deactivate_recursive;
1882 2636
2637 ++$self->{_link_recursion};
2638
1883 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2639 return if UNIVERSAL::isa $self->map, "ext::map_link";
1884 2640
1885 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2641 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1886 if $self->map; 2642 if $self->map && $self->map->{path} ne "{link}";
1887 2643
1888 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2644 $self->enter_map ($LINK_MAP || link_map, 3, 3);
1889} 2645}
1890 2646
1891sub cf::object::player::leave_link { 2647sub cf::object::player::leave_link {
1892 my ($self, $map, $x, $y) = @_; 2648 my ($self, $map, $x, $y) = @_;
2649
2650 return unless $self->contr->active;
1893 2651
1894 my $link_pos = delete $self->{_link_pos}; 2652 my $link_pos = delete $self->{_link_pos};
1895 2653
1896 unless ($map) { 2654 unless ($map) {
1897 # restore original map position 2655 # restore original map position
… …
1908 ($x, $y) = (-1, -1) 2666 ($x, $y) = (-1, -1)
1909 unless (defined $x) && (defined $y); 2667 unless (defined $x) && (defined $y);
1910 2668
1911 # use -1 or undef as default coordinates, not 0, 0 2669 # use -1 or undef as default coordinates, not 0, 0
1912 ($x, $y) = ($map->enter_x, $map->enter_y) 2670 ($x, $y) = ($map->enter_x, $map->enter_y)
1913 if $x <=0 && $y <= 0; 2671 if $x <= 0 && $y <= 0;
1914 2672
1915 $map->load; 2673 $map->load;
1916 $map->load_diag; 2674 $map->load_neighbours;
1917 2675
1918 return unless $self->contr->active; 2676 return unless $self->contr->active;
1919 $self->activate_recursive;
1920 2677
1921 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2678 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1922 $self->enter_map ($map, $x, $y); 2679 if ($self->enter_map ($map, $x, $y)) {
1923} 2680 # entering was successful
1924 2681 delete $self->{_link_recursion};
1925cf::player->attach ( 2682 # only activate afterwards, to support waiting in hooks
1926 on_logout => sub { 2683 $self->activate_recursive;
1927 my ($pl) = @_;
1928
1929 # abort map switching before logout
1930 if ($pl->ob->{_link_pos}) {
1931 cf::sync_job {
1932 $pl->ob->leave_link
1933 };
1934 }
1935 }, 2684 }
1936 on_login => sub {
1937 my ($pl) = @_;
1938 2685
1939 # try to abort aborted map switching on player login :) 2686}
1940 # should happen only on crashes
1941 if ($pl->ob->{_link_pos}) {
1942 $pl->ob->enter_link;
1943 (async {
1944 $pl->ob->reply (undef,
1945 "There was an internal problem at your last logout, "
1946 . "the server will try to bring you to your intended destination in a second.",
1947 cf::NDI_RED);
1948 # we need this sleep as the login has a concurrent enter_exit running
1949 # and this sleep increases chances of the player not ending up in scorn
1950 Coro::Timer::sleep 1;
1951 $pl->ob->leave_link;
1952 })->prio (2);
1953 }
1954 },
1955);
1956 2687
1957=item $player_object->goto ($path, $x, $y) 2688=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
1958 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
1959=cut 2699=cut
2700
2701our $GOTOGEN;
1960 2702
1961sub cf::object::player::goto { 2703sub cf::object::player::goto {
1962 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;
1963 2714
1964 $self->enter_link; 2715 $self->enter_link;
1965 2716
1966 (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
1967 my $map = eval { 2739 my $map = eval {
1968 my $map = cf::map::find $path; 2740 my $map = defined $path ? cf::map::find $path : undef;
2741
2742 if ($map) {
1969 $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
1970 $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 $@;
1971 } or 2755 }
1972 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1973 2756
2757 if ($gen == $self->{_goto_generation}) {
2758 delete $self->{_goto_generation};
1974 $self->leave_link ($map, $x, $y); 2759 $self->leave_link ($map, $x, $y);
2760 }
2761
2762 $done->($self) if $done;
1975 })->prio (1); 2763 })->prio (1);
1976} 2764}
1977 2765
1978=item $player_object->enter_exit ($exit_object) 2766=item $player_object->enter_exit ($exit_object)
1979 2767
… …
1999} 2787}
2000 2788
2001sub prepare_random_map { 2789sub prepare_random_map {
2002 my ($exit) = @_; 2790 my ($exit) = @_;
2003 2791
2004 my $guard = cf::lock_acquire "exit_prepare:$exit";
2005
2006 # all this does is basically replace the /! path by 2792 # all this does is basically replace the /! path by
2007 # a new random map path (?random/...) with a seed 2793 # a new random map path (?random/...) with a seed
2008 # that depends on the exit object 2794 # that depends on the exit object
2009 2795
2010 my $rmp = parse_random_map_params $exit->msg; 2796 my $rmp = parse_random_map_params $exit->msg;
… …
2012 if ($exit->map) { 2798 if ($exit->map) {
2013 $rmp->{region} = $exit->region->name; 2799 $rmp->{region} = $exit->region->name;
2014 $rmp->{origin_map} = $exit->map->path; 2800 $rmp->{origin_map} = $exit->map->path;
2015 $rmp->{origin_x} = $exit->x; 2801 $rmp->{origin_x} = $exit->x;
2016 $rmp->{origin_y} = $exit->y; 2802 $rmp->{origin_y} = $exit->y;
2803
2804 $exit->map->touch;
2017 } 2805 }
2018 2806
2019 $rmp->{random_seed} ||= $exit->random_seed; 2807 $rmp->{random_seed} ||= $exit->random_seed;
2020 2808
2021 my $data = cf::to_json $rmp; 2809 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2022 my $md5 = Digest::MD5::md5_hex $data; 2810 my $md5 = Digest::MD5::md5_hex $data;
2023 my $meta = "$RANDOMDIR/$md5.meta"; 2811 my $meta = "$RANDOMDIR/$md5.meta";
2024 2812
2025 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2813 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2026 aio_write $fh, 0, (length $data), $data, 0; 2814 aio_write $fh, 0, (length $data), $data, 0;
2027 undef $fh; 2815 undef $fh;
2028 aio_rename "$meta~", $meta; 2816 aio_rename "$meta~", $meta;
2029 2817
2818 my $slaying = "?random/$md5";
2819
2820 if ($exit->valid) {
2030 $exit->slaying ("?random/$md5"); 2821 $exit->slaying ("?random/$md5");
2031 $exit->msg (undef); 2822 $exit->msg (undef);
2823 }
2032 } 2824 }
2033} 2825}
2034 2826
2035sub cf::object::player::enter_exit { 2827sub cf::object::player::enter_exit {
2036 my ($self, $exit) = @_; 2828 my ($self, $exit) = @_;
2037 2829
2038 return unless $self->type == cf::PLAYER; 2830 return unless $self->type == cf::PLAYER;
2039 2831
2040 if ($exit->slaying eq "/!") {
2041 #TODO: this should de-fi-ni-te-ly not be a sync-job
2042 # the problem is that $exit might not survive long enough
2043 # so it needs to be done right now, right here
2044 cf::sync_job { prepare_random_map $exit };
2045 }
2046
2047 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2048 my $hp = $exit->stats->hp;
2049 my $sp = $exit->stats->sp;
2050
2051 $self->enter_link; 2832 $self->enter_link;
2052 2833
2053 (async { 2834 (async {
2054 $self->deactivate_recursive; # just to be sure 2835 $Coro::current->{desc} = "enter_exit";
2836
2055 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
2056 $self->goto ($slaying, $hp, $sp); 2852 $self->goto ($map, $x, $y);
2057 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
2058 1; 2858 1
2059 }) { 2859 }) {
2060 $self->message ("Something went wrong deep within the crossfire server. " 2860 $self->message ("Something went wrong deep within the deliantra server. "
2061 . "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. "
2062 . "Please report this to the dungeon master!", 2862 . "Please report this to the dungeon master!",
2063 cf::NDI_UNIQUE | cf::NDI_RED); 2863 cf::NDI_UNIQUE | cf::NDI_RED);
2064 2864
2065 warn "ERROR in enter_exit: $@"; 2865 error "ERROR in enter_exit: $@";
2066 $self->leave_link; 2866 $self->leave_link;
2067 } 2867 }
2068 })->prio (1); 2868 })->prio (1);
2069} 2869}
2070 2870
… …
2084 2884
2085 utf8::encode $text; 2885 utf8::encode $text;
2086 $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);
2087} 2887}
2088 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
2089=item $client->ext_event ($type, %msg) 3076=item $client->ext_msg ($type, @msg)
2090 3077
2091Sends an exti event to the client. 3078Sends an ext event to the client.
2092 3079
2093=cut 3080=cut
2094 3081
2095sub cf::client::ext_event($$%) { 3082sub cf::client::ext_msg($$@) {
2096 my ($self, $type, %msg) = @_; 3083 my ($self, $type, @msg) = @_;
2097 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
2098 $msg{msgtype} = "event_$type"; 3088 push @msg, msgtype => "event_$type";
2099 $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 }
2100} 3109}
2101 3110
2102=item $success = $client->query ($flags, "text", \&cb) 3111=item $success = $client->query ($flags, "text", \&cb)
2103 3112
2104Queues a query to the client, calling the given callback with 3113Queues a query to the client, calling the given callback with
2105the 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>,
2106C<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>.
2107 3116
2108Queries 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
2109reliable at some point in the future. 3118become reliable at some point in the future.
2110 3119
2111=cut 3120=cut
2112 3121
2113sub cf::client::query { 3122sub cf::client::query {
2114 my ($self, $flags, $text, $cb) = @_; 3123 my ($self, $flags, $text, $cb) = @_;
… …
2122 utf8::encode $text; 3131 utf8::encode $text;
2123 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3132 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2124 3133
2125 $self->send_packet ($self->{query_queue}[0][0]) 3134 $self->send_packet ($self->{query_queue}[0][0])
2126 if @{ $self->{query_queue} } == 1; 3135 if @{ $self->{query_queue} } == 1;
3136
3137 1
2127} 3138}
2128 3139
2129cf::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 },
2130 on_reply => sub { 3146 on_reply => sub {
2131 my ($ns, $msg) = @_; 3147 my ($ns, $msg) = @_;
2132 3148
2133 # this weird shuffling is so that direct followup queries 3149 # this weird shuffling is so that direct followup queries
2134 # get handled first 3150 # get handled first
… …
2146 } else { 3162 } else {
2147 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3163 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2148 } 3164 }
2149 } 3165 }
2150 }, 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 },
2151); 3193);
2152 3194
2153=item $client->async (\&cb) 3195=item $client->async (\&cb)
2154 3196
2155Create a new coroutine, running the specified callback. The coroutine will 3197Create a new coroutine, running the specified callback. The coroutine will
… …
2171 3213
2172 $coro 3214 $coro
2173} 3215}
2174 3216
2175cf::client->attach ( 3217cf::client->attach (
2176 on_destroy => sub { 3218 on_client_destroy => sub {
2177 my ($ns) = @_; 3219 my ($ns) = @_;
2178 3220
2179 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3221 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2180 }, 3222 },
2181); 3223);
… …
2196our $safe = new Safe "safe"; 3238our $safe = new Safe "safe";
2197our $safe_hole = new Safe::Hole; 3239our $safe_hole = new Safe::Hole;
2198 3240
2199$SIG{FPE} = 'IGNORE'; 3241$SIG{FPE} = 'IGNORE';
2200 3242
2201$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));
2202 3248
2203# here we export the classes and methods available to script code 3249# here we export the classes and methods available to script code
2204 3250
2205=pod 3251=pod
2206 3252
2207The following functions and methods are available within a safe environment: 3253The following functions and methods are available within a safe environment:
2208 3254
2209 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
2210 cf::object::player player 3260 cf::object::player
2211 cf::player peaceful 3261 player
2212 cf::map trigger 3262
3263 cf::player
3264 peaceful
3265
3266 cf::map
3267 trigger
2213 3268
2214=cut 3269=cut
2215 3270
2216for ( 3271for (
2217 ["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)],
2218 ["cf::object::player" => qw(player)], 3275 ["cf::object::player" => qw(player)],
2219 ["cf::player" => qw(peaceful)], 3276 ["cf::player" => qw(peaceful send_msg)],
2220 ["cf::map" => qw(trigger)], 3277 ["cf::map" => qw(trigger)],
2221) { 3278) {
2222 no strict 'refs';
2223 my ($pkg, @funs) = @$_; 3279 my ($pkg, @funs) = @$_;
2224 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3280 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2225 for @funs; 3281 for @funs;
2226} 3282}
2227 3283
… …
2242 3298
2243 my $qcode = $code; 3299 my $qcode = $code;
2244 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3300 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2245 $qcode =~ s/\n/\\n/g; 3301 $qcode =~ s/\n/\\n/g;
2246 3302
3303 %vars = (_dummy => 0) unless %vars;
3304
3305 my @res;
2247 local $_; 3306 local $_;
2248 local @safe::cf::_safe_eval_args = values %vars;
2249 3307
2250 my $eval = 3308 my $eval =
2251 "do {\n" 3309 "do {\n"
2252 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3310 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2253 . "#line 0 \"{$qcode}\"\n" 3311 . "#line 0 \"{$qcode}\"\n"
2254 . $code 3312 . $code
2255 . "\n}" 3313 . "\n}"
2256 ; 3314 ;
2257 3315
3316 if ($CFG{safe_eval}) {
2258 sub_generation_inc; 3317 sub_generation_inc;
3318 local @safe::cf::_safe_eval_args = values %vars;
2259 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3319 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2260 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 }
2261 3325
2262 if ($@) { 3326 if ($@) {
2263 warn "$@"; 3327 warn "$@",
2264 warn "while executing safe code '$code'\n"; 3328 "while executing safe code '$code'\n",
2265 warn "with arguments " . (join " ", %vars) . "\n"; 3329 "with arguments " . (join " ", %vars) . "\n";
2266 } 3330 }
2267 3331
2268 wantarray ? @res : $res[0] 3332 wantarray ? @res : $res[0]
2269} 3333}
2270 3334
… …
2284=cut 3348=cut
2285 3349
2286sub register_script_function { 3350sub register_script_function {
2287 my ($fun, $cb) = @_; 3351 my ($fun, $cb) = @_;
2288 3352
2289 no strict 'refs'; 3353 $fun = "safe::$fun" if $CFG{safe_eval};
2290 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3354 *$fun = $safe_hole->wrap ($cb);
2291} 3355}
2292 3356
2293=back 3357=back
2294 3358
2295=cut 3359=cut
2296
2297#############################################################################
2298
2299=head2 EXTENSION DATABASE SUPPORT
2300
2301Crossfire maintains a very simple database for extension use. It can
2302currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2303convert to/from binary).
2304
2305The parameter C<$family> should best start with the name of the extension
2306using it, it should be unique.
2307
2308=over 4
2309
2310=item $value = cf::db_get $family => $key
2311
2312Returns a single value from the database.
2313
2314=item cf::db_put $family => $key => $value
2315
2316Stores the given C<$value> in the family.
2317
2318=cut
2319
2320our $DB;
2321
2322sub db_init {
2323 unless ($DB) {
2324 $DB = BDB::db_create $DB_ENV;
2325
2326 cf::sync_job {
2327 eval {
2328 $DB->set_flags (BDB::CHKSUM);
2329
2330 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2331 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2332 cf::cleanup "db_open(db): $!" if $!;
2333 };
2334 cf::cleanup "db_open(db): $@" if $@;
2335 };
2336 }
2337}
2338
2339sub db_get($$) {
2340 my $key = "$_[0]/$_[1]";
2341
2342 cf::sync_job {
2343 BDB::db_get $DB, undef, $key, my $data;
2344
2345 $! ? ()
2346 : $data
2347 }
2348}
2349
2350sub db_put($$$) {
2351 BDB::dbreq_pri 4;
2352 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2353}
2354
2355=item cf::cache $id => [$paths...], $processversion => $process
2356
2357Generic caching function that returns the value of the resource $id,
2358caching and regenerating as required.
2359
2360This function can block.
2361
2362=cut
2363
2364sub cache {
2365 my ($id, $src, $processversion, $process) = @_;
2366
2367 my $meta =
2368 join "\x00",
2369 $processversion,
2370 map {
2371 aio_stat $_
2372 and Carp::croak "$_: $!";
2373
2374 ($_, (stat _)[7,9])
2375 } @$src;
2376
2377 my $dbmeta = db_get cache => "$id/meta";
2378 if ($dbmeta ne $meta) {
2379 # changed, we may need to process
2380
2381 my @data;
2382 my $md5;
2383
2384 for (0 .. $#$src) {
2385 0 <= aio_load $src->[$_], $data[$_]
2386 or Carp::croak "$src->[$_]: $!";
2387 }
2388
2389 # if processing is expensive, check
2390 # checksum first
2391 if (1) {
2392 $md5 =
2393 join "\x00",
2394 $processversion,
2395 map {
2396 Coro::cede;
2397 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2398 } 0.. $#$src;
2399
2400
2401 my $dbmd5 = db_get cache => "$id/md5";
2402 if ($dbmd5 eq $md5) {
2403 db_put cache => "$id/meta", $meta;
2404
2405 return db_get cache => "$id/data";
2406 }
2407 }
2408
2409 my $t1 = Time::HiRes::time;
2410 my $data = $process->(\@data);
2411 my $t2 = Time::HiRes::time;
2412
2413 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2414
2415 db_put cache => "$id/data", $data;
2416 db_put cache => "$id/md5" , $md5;
2417 db_put cache => "$id/meta", $meta;
2418
2419 return $data;
2420 }
2421
2422 db_get cache => "$id/data"
2423}
2424
2425=item fork_call { }, $args
2426
2427Executes the given code block with the given arguments in a seperate
2428process, returning the results. Everything must be serialisable with
2429Coro::Storable. May, of course, block. Note that the executed sub may
2430never block itself or use any form of Event handling.
2431
2432=cut
2433
2434sub fork_call(&@) {
2435 my ($cb, @args) = @_;
2436
2437# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2438# or die "socketpair: $!";
2439 pipe my $fh1, my $fh2
2440 or die "pipe: $!";
2441
2442 if (my $pid = fork) {
2443 close $fh2;
2444
2445 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2446 $res = Coro::Storable::thaw $res;
2447
2448 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2449
2450 die $$res unless "ARRAY" eq ref $res;
2451
2452 return wantarray ? @$res : $res->[-1];
2453 } else {
2454 reset_signals;
2455 local $SIG{__WARN__};
2456 local $SIG{__DIE__};
2457 eval {
2458 close $fh1;
2459
2460 my @res = eval { $cb->(@args) };
2461 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2462 };
2463
2464 warn $@ if $@;
2465 _exit 0;
2466 }
2467}
2468
2469
2470 3360
2471############################################################################# 3361#############################################################################
2472# the server's init and main functions 3362# the server's init and main functions
2473 3363
2474sub load_facedata($) { 3364sub load_facedata($) {
2475 my ($path) = @_; 3365 my ($path) = @_;
2476 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
2477 warn "loading facedata from $path\n"; 3373 trace "loading facedata from $path\n";
2478 3374
2479 my $facedata; 3375 my $facedata;
2480 0 < aio_load $path, $facedata 3376 0 < aio_load $path, $facedata
2481 or die "$path: $!"; 3377 or die "$path: $!";
2482 3378
2483 $facedata = Coro::Storable::thaw $facedata; 3379 $facedata = Coro::Storable::thaw $facedata;
2484 3380
2485 $facedata->{version} == 2 3381 $facedata->{version} == 2
2486 or cf::cleanup "$path: version mismatch, cannot proceed."; 3382 or cf::cleanup "$path: version mismatch, cannot proceed.";
2487 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
2488 { 3393 {
2489 my $faces = $facedata->{faceinfo}; 3394 my $faces = $facedata->{faceinfo};
2490 3395
2491 while (my ($face, $info) = each %$faces) { 3396 while (my ($face, $info) = each %$faces) {
2492 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3397 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3398
2493 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3399 cf::face::set_visibility $idx, $info->{visibility};
3400 cf::face::set_magicmap $idx, $info->{magicmap};
2494 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3401 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2495 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3402 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2496 Coro::cede; 3403
3404 cf::cede_to_tick;
2497 } 3405 }
2498 3406
2499 while (my ($face, $info) = each %$faces) { 3407 while (my ($face, $info) = each %$faces) {
2500 next unless $info->{smooth}; 3408 next unless $info->{smooth};
3409
2501 my $idx = cf::face::find $face 3410 my $idx = cf::face::find $face
2502 or next; 3411 or next;
3412
2503 if (my $smooth = cf::face::find $info->{smooth}) { 3413 if (my $smooth = cf::face::find $info->{smooth}) {
3414 cf::face::set_smooth $idx, $smooth;
2504 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3415 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2505 } else { 3416 } else {
2506 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3417 error "smooth face '$info->{smooth}' not found for face '$face'";
2507 } 3418 }
2508 Coro::cede; 3419
3420 cf::cede_to_tick;
2509 } 3421 }
2510 } 3422 }
2511 3423
2512 { 3424 {
2513 my $anims = $facedata->{animinfo}; 3425 my $anims = $facedata->{animinfo};
2514 3426
2515 while (my ($anim, $info) = each %$anims) { 3427 while (my ($anim, $info) = each %$anims) {
2516 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3428 cf::anim::set $anim, $info->{frames}, $info->{facings};
2517 Coro::cede; 3429 cf::cede_to_tick;
2518 } 3430 }
2519 3431
2520 cf::anim::invalidate_all; # d'oh 3432 cf::anim::invalidate_all; # d'oh
2521 } 3433 }
2522 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
2523 1 3454 1
2524} 3455}
2525 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
2526sub 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
2527 load_resource_file "$MAPDIR/regions" 3480 load_resource_file "$MAPDIR/regions"
2528 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 }
2529} 3487}
2530 3488
2531sub reload_facedata { 3489sub reload_facedata {
2532 load_facedata "$DATADIR/facedata" 3490 load_facedata "$DATADIR/facedata"
2533 or die "unable to load facedata\n"; 3491 or die "unable to load facedata\n";
… …
2541sub reload_treasures { 3499sub reload_treasures {
2542 load_resource_file "$DATADIR/treasures" 3500 load_resource_file "$DATADIR/treasures"
2543 or die "unable to load treasurelists\n"; 3501 or die "unable to load treasurelists\n";
2544} 3502}
2545 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
2546sub reload_resources { 3527sub reload_resources {
2547 warn "reloading resource files...\n"; 3528 trace "reloading resource files...\n";
2548 3529
3530 reload_exp_table;
3531 reload_materials;
3532 reload_facedata;
3533 reload_sound;
3534 reload_archetypes;
2549 reload_regions; 3535 reload_regions;
2550 reload_facedata;
2551 reload_archetypes;
2552 reload_treasures; 3536 reload_treasures;
2553 3537
2554 warn "finished reloading resource files\n"; 3538 trace "finished reloading resource files\n";
2555} 3539}
2556 3540
2557sub init { 3541sub reload_config {
2558 reload_resources; 3542 trace "reloading config file...\n";
2559}
2560 3543
2561sub cfg_load {
2562 open my $fh, "<:utf8", "$CONFDIR/config" 3544 open my $fh, "<:utf8", "$CONFDIR/config"
2563 or return; 3545 or return;
2564 3546
2565 local $/; 3547 local $/;
2566 *CFG = YAML::Syck::Load <$fh>; 3548 *CFG = YAML::XS::Load scalar <$fh>;
2567 3549
2568 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3550 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
2569 3551
2570 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3552 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2571 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3553 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2572 3554
2573 if (exists $CFG{mlockall}) { 3555 if (exists $CFG{mlockall}) {
… …
2575 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3557 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2576 and die "WARNING: m(un)lockall failed: $!\n"; 3558 and die "WARNING: m(un)lockall failed: $!\n";
2577 }; 3559 };
2578 warn $@ if $@; 3560 warn $@ if $@;
2579 } 3561 }
3562
3563 trace "finished reloading resource files\n";
3564}
3565
3566sub pidfile() {
3567 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3568 or die "$PIDFILE: $!";
3569 flock $fh, &Fcntl::LOCK_EX
3570 or die "$PIDFILE: flock: $!";
3571 $fh
3572}
3573
3574# make sure only one server instance is running at any one time
3575sub atomic {
3576 my $fh = pidfile;
3577
3578 my $pid = <$fh>;
3579 kill 9, $pid if $pid > 0;
3580
3581 seek $fh, 0, 0;
3582 print $fh $$;
3583}
3584
3585sub main_loop {
3586 trace "EV::loop starting\n";
3587 if (1) {
3588 EV::loop;
3589 }
3590 trace "EV::loop returned\n";
3591 goto &main_loop unless $REALLY_UNLOOP;
2580} 3592}
2581 3593
2582sub main { 3594sub main {
3595 cf::init_globals; # initialise logging
3596
3597 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3598 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3599 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3600 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3601
3602 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3603
2583 # we must not ever block the main coroutine 3604 # we must not ever block the main coroutine
2584 local $Coro::idle = sub { 3605 local $Coro::idle = sub {
2585 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3606 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2586 (async { 3607 (async {
2587 Event::one_event; 3608 $Coro::current->{desc} = "IDLE BUG HANDLER";
3609 EV::loop EV::LOOP_ONESHOT;
2588 })->prio (Coro::PRIO_MAX); 3610 })->prio (Coro::PRIO_MAX);
2589 }; 3611 };
2590 3612
2591 cfg_load; 3613 evthread_start IO::AIO::poll_fileno;
3614
3615 cf::sync_job {
3616 cf::incloader::init ();
3617
3618 cf::init_anim;
3619 cf::init_attackmess;
3620 cf::init_dynamic;
3621
3622 cf::load_settings;
3623
3624 reload_resources;
3625 reload_config;
2592 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
2593 load_extensions; 3636 load_extensions;
2594 3637
2595 $TICK_WATCHER->start; 3638 utime time, time, $RUNTIMEFILE;
2596 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;
2597} 3656}
2598 3657
2599############################################################################# 3658#############################################################################
2600# initialisation and cleanup 3659# initialisation and cleanup
2601 3660
2602# install some emergency cleanup handlers 3661# install some emergency cleanup handlers
2603BEGIN { 3662BEGIN {
3663 our %SIGWATCHER = ();
2604 for my $signal (qw(INT HUP TERM)) { 3664 for my $signal (qw(INT HUP TERM)) {
2605 Event->signal ( 3665 $SIGWATCHER{$signal} = AE::signal $signal, sub {
2606 reentrant => 0,
2607 data => WF_AUTOCANCEL,
2608 signal => $signal,
2609 prio => 0,
2610 cb => sub {
2611 cf::cleanup "SIG$signal"; 3666 cf::cleanup "SIG$signal";
2612 },
2613 ); 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
2614 } 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 };
2615} 3757}
2616 3758
2617sub emergency_save() { 3759sub emergency_save() {
2618 my $freeze_guard = cf::freeze_mainloop; 3760 my $freeze_guard = cf::freeze_mainloop;
2619 3761
2620 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;
2621 3768
2622 cf::sync_job { 3769 cf::sync_job {
3770 cf::write_runtime_sync; # external watchdog should not bark
3771
2623 # use a peculiar iteration method to avoid tripping on perl 3772 # use a peculiar iteration method to avoid tripping on perl
2624 # refcount bugs in for. also avoids problems with players 3773 # refcount bugs in for. also avoids problems with players
2625 # and maps saved/destroyed asynchronously. 3774 # and maps saved/destroyed asynchronously.
2626 warn "begin emergency player save\n"; 3775 info "emergency_perl_save: begin player save\n";
2627 for my $login (keys %cf::PLAYER) { 3776 for my $login (keys %cf::PLAYER) {
2628 my $pl = $cf::PLAYER{$login} or next; 3777 my $pl = $cf::PLAYER{$login} or next;
2629 $pl->valid or next; 3778 $pl->valid or next;
3779 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2630 $pl->save; 3780 $pl->save;
2631 } 3781 }
2632 warn "end emergency player save\n"; 3782 info "emergency_perl_save: end player save\n";
2633 3783
2634 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";
2635 for my $path (keys %cf::MAP) { 3787 for my $path (keys %cf::MAP) {
2636 my $map = $cf::MAP{$path} or next; 3788 my $map = $cf::MAP{$path} or next;
2637 $map->valid or next; 3789 $map->valid or next;
2638 $map->save; 3790 $map->save;
2639 } 3791 }
2640 warn "end emergency map save\n"; 3792 info "emergency_perl_save: end map save\n";
2641 3793
2642 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";
2643 BDB::db_env_txn_checkpoint $DB_ENV; 3797 BDB::db_env_txn_checkpoint $DB_ENV;
2644 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
2645 }; 3822 };
2646 3823
2647 warn "leave emergency perl save\n"; 3824 info "emergency_perl_save: leave\n";
2648} 3825}
2649 3826
2650sub post_cleanup { 3827sub post_cleanup {
2651 my ($make_core) = @_; 3828 my ($make_core) = @_;
2652 3829
3830 IO::AIO::flush;
3831
2653 warn Carp::longmess "post_cleanup backtrace" 3832 error Carp::longmess "post_cleanup backtrace"
2654 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 }
2655} 3862}
2656 3863
2657sub do_reload_perl() { 3864sub do_reload_perl() {
2658 # can/must only be called in main 3865 # can/must only be called in main
2659 if ($Coro::current != $Coro::main) { 3866 unless (in_main) {
2660 warn "can only reload from main coroutine"; 3867 error "can only reload from main coroutine";
2661 return; 3868 return;
2662 } 3869 }
2663 3870
3871 return if $RELOAD++;
3872
3873 my $t1 = AE::time;
3874
3875 while ($RELOAD) {
3876 cf::get_slot 0.1, -1, "reload_perl";
2664 warn "reloading..."; 3877 info "reloading...";
2665 3878
2666 warn "entering sync_job"; 3879 trace "entering sync_job";
2667 3880
2668 cf::sync_job { 3881 cf::sync_job {
2669 cf::write_runtime; # external watchdog should not bark
2670 cf::emergency_save; 3882 #cf::emergency_save;
2671 cf::write_runtime; # external watchdog should not bark
2672 3883
2673 warn "syncing database to disk";
2674 BDB::db_env_txn_checkpoint $DB_ENV;
2675
2676 # if anything goes wrong in here, we should simply crash as we already saved
2677
2678 warn "cancelling all WF_AUTOCANCEL watchers";
2679 for (Event::all_watchers) {
2680 $_->cancel if $_->data & WF_AUTOCANCEL;
2681 }
2682
2683 warn "flushing outstanding aio requests";
2684 for (;;) {
2685 BDB::flush;
2686 IO::AIO::flush;
2687 Coro::cede;
2688 last unless IO::AIO::nreqs || BDB::nreqs;
2689 warn "iterate...";
2690 }
2691
2692 ++$RELOAD;
2693
2694 warn "cancelling all extension coros"; 3884 trace "cancelling all extension coros";
2695 $_->cancel for values %EXT_CORO; 3885 $_->cancel for values %EXT_CORO;
2696 %EXT_CORO = (); 3886 %EXT_CORO = ();
2697 3887
2698 warn "removing commands"; 3888 trace "removing commands";
2699 %COMMAND = (); 3889 %COMMAND = ();
2700 3890
2701 warn "removing ext commands"; 3891 trace "removing ext/exti commands";
2702 %EXTCMD = (); 3892 %EXTCMD = ();
3893 %EXTICMD = ();
2703 3894
2704 warn "unloading/nuking all extensions"; 3895 trace "unloading/nuking all extensions";
2705 for my $pkg (@EXTS) { 3896 for my $pkg (@EXTS) {
2706 warn "... unloading $pkg"; 3897 trace "... unloading $pkg";
2707 3898
2708 if (my $cb = $pkg->can ("unload")) { 3899 if (my $cb = $pkg->can ("unload")) {
2709 eval { 3900 eval {
2710 $cb->($pkg); 3901 $cb->($pkg);
2711 1 3902 1
2712 } 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;
2713 } 3908 }
2714 3909
2715 warn "... nuking $pkg";
2716 Symbol::delete_package $pkg;
2717 }
2718
2719 warn "unloading all perl modules loaded from $LIBDIR"; 3910 trace "unloading all perl modules loaded from $LIBDIR";
2720 while (my ($k, $v) = each %INC) { 3911 while (my ($k, $v) = each %INC) {
2721 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3912 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2722 3913
2723 warn "... unloading $k"; 3914 trace "... unloading $k";
2724 delete $INC{$k}; 3915 delete $INC{$k};
2725 3916
2726 $k =~ s/\.pm$//; 3917 $k =~ s/\.pm$//;
2727 $k =~ s/\//::/g; 3918 $k =~ s/\//::/g;
2728 3919
2729 if (my $cb = $k->can ("unload_module")) { 3920 if (my $cb = $k->can ("unload_module")) {
2730 $cb->(); 3921 $cb->();
3922 }
3923
3924 clear_package $k;
2731 } 3925 }
2732 3926
2733 Symbol::delete_package $k;
2734 }
2735
2736 warn "getting rid of safe::, as good as possible"; 3927 trace "getting rid of safe::, as good as possible";
2737 Symbol::delete_package "safe::$_" 3928 clear_package "safe::$_"
2738 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);
2739 3930
2740 warn "unloading cf.pm \"a bit\""; 3931 trace "unloading cf.pm \"a bit\"";
2741 delete $INC{"cf.pm"}; 3932 delete $INC{"cf.pm"};
2742 delete $INC{"cf/pod.pm"}; 3933 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2743 3934
2744 # don't, removes xs symbols, too, 3935 # don't, removes xs symbols, too,
2745 # and global variables created in xs 3936 # and global variables created in xs
2746 #Symbol::delete_package __PACKAGE__; 3937 #clear_package __PACKAGE__;
2747 3938
2748 warn "unload completed, starting to reload now"; 3939 info "unload completed, starting to reload now";
2749 3940
2750 warn "reloading cf.pm"; 3941 trace "reloading cf.pm";
2751 require cf; 3942 require cf;
2752 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3943 cf::_connect_to_perl_1;
2753 3944
2754 warn "loading config and database again"; 3945 trace "loading config and database again";
2755 cf::cfg_load; 3946 cf::reload_config;
2756 3947
2757 warn "loading extensions"; 3948 trace "loading extensions";
2758 cf::load_extensions; 3949 cf::load_extensions;
2759 3950
3951 if ($REATTACH_ON_RELOAD) {
2760 warn "reattaching attachments to objects/players"; 3952 trace "reattaching attachments to objects/players";
2761 _global_reattach; # objects, sockets 3953 _global_reattach; # objects, sockets
2762 warn "reattaching attachments to maps"; 3954 trace "reattaching attachments to maps";
2763 reattach $_ for values %MAP; 3955 reattach $_ for values %MAP;
2764 warn "reattaching attachments to players"; 3956 trace "reattaching attachments to players";
2765 reattach $_ for values %PLAYER; 3957 reattach $_ for values %PLAYER;
3958 }
2766 3959
3960 trace "running post_init jobs";
3961 (pop @POST_INIT)->(1) while @POST_INIT;
3962
2767 warn "leaving sync_job"; 3963 trace "leaving sync_job";
2768 3964
2769 1 3965 1
2770 } or do { 3966 } or do {
2771 warn $@; 3967 error $@;
2772 warn "error while reloading, exiting."; 3968 cf::cleanup "error while reloading, exiting.";
2773 exit 1; 3969 };
3970
3971 info "reloaded";
3972 --$RELOAD;
2774 }; 3973 }
2775 3974
2776 warn "reloaded"; 3975 $t1 = AE::time - $t1;
3976 info "reload completed in ${t1}s\n";
2777}; 3977};
2778 3978
2779our $RELOAD_WATCHER; # used only during reload 3979our $RELOAD_WATCHER; # used only during reload
2780 3980
2781sub reload_perl() { 3981sub reload_perl() {
2782 # doing reload synchronously and two reloads happen back-to-back, 3982 # doing reload synchronously and two reloads happen back-to-back,
2783 # coro crashes during coro_state_free->destroy here. 3983 # coro crashes during coro_state_free->destroy here.
2784 3984
2785 $RELOAD_WATCHER ||= Event->timer ( 3985 $RELOAD_WATCHER ||= cf::async {
2786 reentrant => 0, 3986 Coro::AIO::aio_wait cache_extensions;
2787 after => 0, 3987
2788 data => WF_AUTOCANCEL, 3988 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
2789 cb => sub {
2790 do_reload_perl; 3989 do_reload_perl;
2791 undef $RELOAD_WATCHER; 3990 undef $RELOAD_WATCHER;
2792 }, 3991 };
2793 ); 3992 };
2794} 3993}
2795 3994
2796register_command "reload" => sub { 3995register_command "reload" => sub {
2797 my ($who, $arg) = @_; 3996 my ($who, $arg) = @_;
2798 3997
2799 if ($who->flag (FLAG_WIZ)) { 3998 if ($who->flag (FLAG_WIZ)) {
2800 $who->message ("reloading server."); 3999 $who->message ("reloading server.");
4000 async {
4001 $Coro::current->{desc} = "perl_reload";
2801 async { reload_perl }; 4002 reload_perl;
4003 };
2802 } 4004 }
2803}; 4005};
2804 4006
2805unshift @INC, $LIBDIR; 4007#############################################################################
2806 4008
2807my $bug_warning = 0; 4009my $bug_warning = 0;
2808 4010
2809our @WAIT_FOR_TICK; 4011our @WAIT_FOR_TICK;
2810our @WAIT_FOR_TICK_BEGIN; 4012our @WAIT_FOR_TICK_BEGIN;
2811 4013
2812sub wait_for_tick { 4014sub wait_for_tick {
2813 return unless $TICK_WATCHER->is_active;
2814 return if $Coro::current == $Coro::main; 4015 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2815 4016
2816 my $signal = new Coro::Signal; 4017 my $signal = new Coro::Signal;
2817 push @WAIT_FOR_TICK, $signal; 4018 push @WAIT_FOR_TICK, $signal;
2818 $signal->wait; 4019 $signal->wait;
2819} 4020}
2820 4021
2821sub wait_for_tick_begin { 4022sub wait_for_tick_begin {
2822 return unless $TICK_WATCHER->is_active;
2823 return if $Coro::current == $Coro::main; 4023 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2824 4024
2825 my $signal = new Coro::Signal; 4025 my $signal = new Coro::Signal;
2826 push @WAIT_FOR_TICK_BEGIN, $signal; 4026 push @WAIT_FOR_TICK_BEGIN, $signal;
2827 $signal->wait; 4027 $signal->wait;
2828} 4028}
2829 4029
2830$TICK_WATCHER = Event->timer ( 4030sub tick {
2831 reentrant => 0,
2832 parked => 1,
2833 prio => 0,
2834 at => $NEXT_TICK || $TICK,
2835 data => WF_AUTOCANCEL,
2836 cb => sub {
2837 if ($Coro::current != $Coro::main) { 4031 if ($Coro::current != $Coro::main) {
2838 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"
2839 unless ++$bug_warning > 10; 4033 unless ++$bug_warning > 10;
2840 return; 4034 return;
2841 } 4035 }
2842 4036
2843 $NOW = Event::time;
2844
2845 cf::server_tick; # one server iteration 4037 cf::server_tick; # one server iteration
2846 4038
2847 $RUNTIME += $TICK; 4039 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
2848 $NEXT_TICK += $TICK;
2849 4040
2850 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4041 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2851 $NEXT_RUNTIME_WRITE = $NOW + 10; 4042 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2852 Coro::async_pool { 4043 Coro::async_pool {
4044 $Coro::current->{desc} = "runtime saver";
2853 write_runtime 4045 write_runtime_sync
2854 or warn "ERROR: unable to write runtime file: $!"; 4046 or error "ERROR: unable to write runtime file: $!";
2855 };
2856 } 4047 };
4048 }
2857 4049
2858# my $AFTER = Event::time;
2859# warn $AFTER - $NOW;#d#
2860
2861 # if we are delayed by four ticks or more, skip them all
2862 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2863
2864 $TICK_WATCHER->at ($NEXT_TICK);
2865 $TICK_WATCHER->start;
2866
2867 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4050 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2868 $sig->send; 4051 $sig->send;
2869 } 4052 }
2870 while (my $sig = shift @WAIT_FOR_TICK) { 4053 while (my $sig = shift @WAIT_FOR_TICK) {
2871 $sig->send; 4054 $sig->send;
2872 }
2873
2874 _post_tick;
2875 }, 4055 }
2876); 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}
2877 4068
2878{ 4069{
2879 BDB::max_poll_time $TICK * 0.1; 4070 # configure BDB
2880 $BDB_POLL_WATCHER = Event->io ( 4071
2881 reentrant => 0,
2882 fd => BDB::poll_fileno,
2883 poll => 'r',
2884 prio => 0,
2885 data => WF_AUTOCANCEL,
2886 cb => \&BDB::poll_cb,
2887 );
2888 BDB::min_parallel 8; 4072 BDB::min_parallel 16;
2889 4073 BDB::max_poll_reqs $TICK * 0.1;
2890 BDB::set_sync_prepare { 4074 $AnyEvent::BDB::WATCHER->priority (1);
2891 my $status;
2892 my $current = $Coro::current;
2893 (
2894 sub {
2895 $status = $!;
2896 $current->ready; undef $current;
2897 },
2898 sub {
2899 Coro::schedule while defined $current;
2900 $! = $status;
2901 },
2902 )
2903 };
2904 4075
2905 unless ($DB_ENV) { 4076 unless ($DB_ENV) {
2906 $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);
2907 4083
2908 cf::sync_job { 4084 cf::sync_job {
2909 eval { 4085 eval {
2910 BDB::db_env_open 4086 BDB::db_env_open
2911 $DB_ENV, 4087 $DB_ENV,
… …
2913 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
2914 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4090 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2915 0666; 4091 0666;
2916 4092
2917 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4093 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2918
2919 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2920 $DB_ENV->set_lk_detect;
2921 }; 4094 };
2922 4095
2923 cf::cleanup "db_env_open(db): $@" if $@; 4096 cf::cleanup "db_env_open(db): $@" if $@;
2924 }; 4097 };
2925 } 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 };
2926} 4109}
2927 4110
2928{ 4111{
4112 # configure IO::AIO
4113
2929 IO::AIO::min_parallel 8; 4114 IO::AIO::min_parallel 8;
2930
2931 undef $Coro::AIO::WATCHER;
2932 IO::AIO::max_poll_time $TICK * 0.1; 4115 IO::AIO::max_poll_time $TICK * 0.1;
2933 $AIO_POLL_WATCHER = Event->io ( 4116 undef $AnyEvent::AIO::WATCHER;
2934 reentrant => 0,
2935 data => WF_AUTOCANCEL,
2936 fd => IO::AIO::poll_fileno,
2937 poll => 'r',
2938 prio => 6,
2939 cb => \&IO::AIO::poll_cb,
2940 );
2941} 4117}
2942 4118
2943my $_log_backtrace; 4119my $_log_backtrace;
2944 4120
2945sub _log_backtrace { 4121sub _log_backtrace {
… …
2948 $msg =~ s/\n//; 4124 $msg =~ s/\n//;
2949 4125
2950 # limit the # of concurrent backtraces 4126 # limit the # of concurrent backtraces
2951 if ($_log_backtrace < 2) { 4127 if ($_log_backtrace < 2) {
2952 ++$_log_backtrace; 4128 ++$_log_backtrace;
4129 my $perl_bt = Carp::longmess $msg;
2953 async { 4130 async {
4131 $Coro::current->{desc} = "abt $msg";
4132
2954 my @bt = fork_call { 4133 my @bt = fork_call {
2955 @addr = map { sprintf "%x", $_ } @addr; 4134 @addr = map { sprintf "%x", $_ } @addr;
2956 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 4135 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
2957 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 |"
2958 or die "addr2line: $!"; 4137 or die "addr2line: $!";
… …
2966 } 4145 }
2967 4146
2968 @funcs 4147 @funcs
2969 }; 4148 };
2970 4149
2971 LOG llevInfo, "[ABT] $msg\n"; 4150 LOG llevInfo, "[ABT] $perl_bt\n";
4151 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
2972 LOG llevInfo, "[ABT] $_\n" for @bt; 4152 LOG llevInfo, "[ABT] $_\n" for @bt;
2973 --$_log_backtrace; 4153 --$_log_backtrace;
2974 }; 4154 };
2975 } else { 4155 } else {
2976 LOG llevInfo, "[ABT] $msg\n"; 4156 LOG llevInfo, "[ABT] $msg\n";
2977 LOG llevInfo, "[ABT] [suppressed]\n"; 4157 LOG llevInfo, "[ABT] [suppressed]\n";
2978 } 4158 }
2979} 4159}
2980 4160
2981# load additional modules 4161# load additional modules
2982use cf::pod; 4162require "cf/$_.pm" for @EXTRA_MODULES;
4163cf::_connect_to_perl_2;
2983 4164
2984END { cf::emergency_save } 4165END { cf::emergency_save }
2985 4166
29861 41671
2987 4168

Diff Legend

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