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

Diff Legend

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