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.253 by root, Wed Apr 18 17:32:07 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-\x09\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) = @_;
… …
1352 1972
1353# the original (read-only) location 1973# the original (read-only) location
1354sub load_path { 1974sub load_path {
1355 my ($self) = @_; 1975 my ($self) = @_;
1356 1976
1357 "$MAPDIR($self->{path}" 1977 "$MAPDIR/$self->{path}.map"
1358} 1978}
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" 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};
2123
2124 {
1495 my $guard = cf::lock_acquire "map_load:$path"; 2125 my $guard = cf::lock_acquire "map_data:$path";
1496 2126
2127 return unless $self->valid;
1497 return if $self->in_memory != cf::MAP_SWAPPED; 2128 return unless $self->in_memory == cf::MAP_SWAPPED;
1498 2129
1499 $self->in_memory (cf::MAP_LOADING); 2130 $self->in_memory (cf::MAP_LOADING);
1500 2131
1501 $self->alloc; 2132 $self->alloc;
1502 2133
1503 $self->pre_load; 2134 $self->pre_load;
1504 Coro::cede; 2135 cf::cede_to_tick;
1505 2136
1506 $self->_load_objects ($self->{load_path}, 1) 2137 my $f = new_from_file cf::object::thawer $self->{load_path};
2138 $f->skip_block;
2139 $self->_load_objects ($f)
1507 or return; 2140 or return;
1508 2141
1509 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2142 $self->post_load_original
1510 if delete $self->{load_original}; 2143 if delete $self->{load_original};
1511 2144
1512 if (my $uniq = $self->uniq_path) { 2145 if (my $uniq = $self->uniq_path) {
1513 utf8::encode $uniq; 2146 utf8::encode $uniq;
1514 if (aio_open $uniq, O_RDONLY, 0) { 2147 unless (aio_stat $uniq) {
2148 if (my $f = new_from_file cf::object::thawer $uniq) {
1515 $self->clear_unique_items; 2149 $self->clear_unique_items;
1516 $self->_load_objects ($uniq, 0); 2150 $self->_load_objects ($f);
2151 $f->resolve_delayed_derefs;
2152 }
1517 } 2153 }
1518 } 2154 }
1519 2155
1520 Coro::cede; 2156 $f->resolve_delayed_derefs;
2157
2158 cf::cede_to_tick;
1521 # now do the right thing for maps 2159 # now do the right thing for maps
1522 $self->link_multipart_objects; 2160 $self->link_multipart_objects;
1523 Coro::cede;
1524
1525 unless ($self->{deny_activate}) {
1526 $self->decay_objects;
1527 $self->fix_auto_apply;
1528 $self->update_buttons;
1529 Coro::cede;
1530 $self->set_darkness_map;
1531 $self->difficulty ($self->estimate_difficulty) 2161 $self->difficulty ($self->estimate_difficulty)
1532 unless $self->difficulty; 2162 unless $self->difficulty;
1533 Coro::cede; 2163 cf::cede_to_tick;
2164
2165 unless ($self->{deny_activate}) {
2166 $self->decay_objects;
2167 $self->fix_auto_apply;
2168 $self->update_buttons;
2169 cf::cede_to_tick;
1534 $self->activate; 2170 $self->activate;
1535 Coro::cede; 2171 }
2172
2173 $self->{last_save} = $cf::RUNTIME;
2174 $self->last_access ($cf::RUNTIME);
2175
2176 $self->in_memory (cf::MAP_ACTIVE);
1536 } 2177 }
1537 2178
1538 $self->post_load; 2179 $self->post_load;
1539 Coro::cede;
1540 2180
1541 $self->in_memory (cf::MAP_IN_MEMORY); 2181 1
1542} 2182}
1543 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
1544sub customise_for { 2187sub customise_for {
1545 my ($self, $ob) = @_; 2188 my ($self, $ob) = @_;
1546 2189
1547 return find "~" . $ob->name . "/" . $self->{path} 2190 return find "~" . $ob->name . "/" . $self->{path}
1548 if $self->per_player; 2191 if $self->per_player;
1549 2192
2193# return find "?party/" . $ob->name . "/" . $self->{path}
2194# if $self->per_party;
2195
1550 $self 2196 $self
1551} 2197}
1552 2198
1553# 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
1554sub load_diag { 2200sub load_neighbours {
1555 my ($map) = @_; 2201 my ($map) = @_;
1556 2202
1557 my @diag; # diagonal neighbours 2203 my @neigh; # diagonal neighbours
1558 2204
1559 for (0 .. 3) { 2205 for (0 .. 3) {
1560 my $neigh = $map->tile_path ($_) 2206 my $neigh = $map->tile_path ($_)
1561 or next; 2207 or next;
1562 $neigh = find $neigh, $map 2208 $neigh = find $neigh, $map
1563 or next; 2209 or next;
1564 $neigh->load; 2210 $neigh->load;
1565 2211
2212 # now find the diagonal neighbours
2213 push @neigh,
1566 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2214 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1567 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2215 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1568 } 2216 }
1569 2217
1570 for (@diag) { 2218 for (grep defined $_->[0], @neigh) {
2219 my ($path, $origin) = @$_;
1571 my $neigh = find @$_ 2220 my $neigh = find $path, $origin
1572 or next; 2221 or next;
1573 $neigh->load; 2222 $neigh->load;
1574 } 2223 }
1575} 2224}
1576 2225
1577sub find_sync { 2226sub find_sync {
1578 my ($path, $origin) = @_; 2227 my ($path, $origin) = @_;
1579 2228
1580 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
1581} 2233}
1582 2234
1583sub do_load_sync { 2235sub do_load_sync {
1584 my ($map) = @_; 2236 my ($map) = @_;
1585 2237
1586 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;
1587} 2242}
1588 2243
1589our %MAP_PREFETCH; 2244our %MAP_PREFETCH;
1590our $MAP_PREFETCHER = undef; 2245our $MAP_PREFETCHER = undef;
1591 2246
1592sub find_async { 2247sub find_async {
1593 my ($path, $origin) = @_; 2248 my ($path, $origin, $load) = @_;
1594 2249
1595 $path = normalise $path, $origin && $origin->{path}; 2250 $path = normalise $path, $origin && $origin->{path};
1596 2251
1597 if (my $map = $cf::MAP{$path}) { 2252 if (my $map = $cf::MAP{$path}) {
1598 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2253 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1599 } 2254 }
1600 2255
1601 undef $MAP_PREFETCH{$path}; 2256 $MAP_PREFETCH{$path} |= $load;
2257
1602 $MAP_PREFETCHER ||= cf::async { 2258 $MAP_PREFETCHER ||= cf::async {
2259 $Coro::current->{desc} = "map prefetcher";
2260
1603 while (%MAP_PREFETCH) { 2261 while (%MAP_PREFETCH) {
1604 for my $path (keys %MAP_PREFETCH) { 2262 while (my ($k, $v) = each %MAP_PREFETCH) {
1605 my $map = find $path 2263 if (my $map = find $k) {
1606 or next;
1607 $map->load; 2264 $map->load if $v;
2265 }
1608 2266
1609 delete $MAP_PREFETCH{$path}; 2267 delete $MAP_PREFETCH{$k};
1610 } 2268 }
1611 } 2269 }
1612 undef $MAP_PREFETCHER; 2270 undef $MAP_PREFETCHER;
1613 }; 2271 };
1614 $MAP_PREFETCHER->prio (6); 2272 $MAP_PREFETCHER->prio (6);
1615 2273
1616 () 2274 ()
1617} 2275}
1618 2276
2277# common code, used by both ->save and ->swapout
1619sub save { 2278sub _save {
1620 my ($self) = @_; 2279 my ($self) = @_;
1621
1622 my $lock = cf::lock_acquire "map_data:" . $self->path;
1623 2280
1624 $self->{last_save} = $cf::RUNTIME; 2281 $self->{last_save} = $cf::RUNTIME;
1625 2282
1626 return unless $self->dirty; 2283 return unless $self->dirty;
1627 2284
… …
1633 return if $self->{deny_save}; 2290 return if $self->{deny_save};
1634 2291
1635 local $self->{last_access} = $self->last_access;#d# 2292 local $self->{last_access} = $self->last_access;#d#
1636 2293
1637 cf::async { 2294 cf::async {
2295 $Coro::current->{desc} = "map player save";
1638 $_->contr->save for $self->players; 2296 $_->contr->save for $self->players;
1639 }; 2297 };
2298
2299 cf::get_slot 0.02;
1640 2300
1641 if ($uniq) { 2301 if ($uniq) {
1642 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2302 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1643 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2303 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1644 } else { 2304 } else {
1645 $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);
1646 } 2306 }
1647} 2307}
1648 2308
2309sub save {
2310 my ($self) = @_;
2311
2312 my $lock = cf::lock_acquire "map_data:$self->{path}";
2313
2314 $self->_save;
2315}
2316
1649sub swap_out { 2317sub swap_out {
1650 my ($self) = @_; 2318 my ($self) = @_;
1651 2319
1652 # save first because save cedes
1653 $self->save;
1654
1655 my $lock = cf::lock_acquire "map_data:" . $self->path; 2320 my $lock = cf::lock_acquire "map_data:$self->{path}";
1656 2321
2322 return if $self->in_memory != cf::MAP_ACTIVE;
2323 return if $self->{deny_save};
1657 return if $self->players; 2324 return if $self->players;
1658 return if $self->in_memory != cf::MAP_IN_MEMORY;
1659 return if $self->{deny_save};
1660 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
1661 $self->clear; 2335 $self->clear;
1662 $self->in_memory (cf::MAP_SWAPPED);
1663} 2336}
1664 2337
1665sub reset_at { 2338sub reset_at {
1666 my ($self) = @_; 2339 my ($self) = @_;
1667 2340
1668 # TODO: safety, remove and allow resettable per-player maps 2341 # TODO: safety, remove and allow resettable per-player maps
1669 return 1e99 if $self->isa ("ext::map_per_player");#d#
1670 return 1e99 if $self->{deny_reset}; 2342 return 1e99 if $self->{deny_reset};
1671 2343
1672 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2344 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1673 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;
1674 2346
… …
1685 my ($self) = @_; 2357 my ($self) = @_;
1686 2358
1687 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2359 my $lock = cf::lock_acquire "map_data:$self->{path}";
1688 2360
1689 return if $self->players; 2361 return if $self->players;
1690 return if $self->isa ("ext::map_per_player");#d#
1691 2362
1692 warn "resetting map ", $self->path;#d# 2363 cf::trace "resetting map ", $self->path, "\n";
1693 2364
1694 $self->in_memory (cf::MAP_SWAPPED); 2365 $self->in_memory (cf::MAP_SWAPPED);
1695 2366
1696 # need to save uniques path 2367 # need to save uniques path
1697 unless ($self->{deny_save}) { 2368 unless ($self->{deny_save}) {
… …
1701 if $uniq; 2372 if $uniq;
1702 } 2373 }
1703 2374
1704 delete $cf::MAP{$self->path}; 2375 delete $cf::MAP{$self->path};
1705 2376
2377 $self->deactivate;
2378 $_->clear_links_to ($self) for values %cf::MAP;
1706 $self->clear; 2379 $self->clear;
1707
1708 $_->clear_links_to ($self) for values %cf::MAP;
1709 2380
1710 $self->unlink_save; 2381 $self->unlink_save;
1711 $self->destroy; 2382 $self->destroy;
1712} 2383}
1713 2384
1714my $nuke_counter = "aaaa"; 2385my $nuke_counter = "aaaa";
1715 2386
1716sub nuke { 2387sub nuke {
1717 my ($self) = @_; 2388 my ($self) = @_;
1718 2389
2390 {
2391 my $lock = cf::lock_acquire "map_data:$self->{path}";
2392
1719 delete $cf::MAP{$self->path}; 2393 delete $cf::MAP{$self->path};
1720 2394
1721 $self->unlink_save; 2395 $self->unlink_save;
1722 2396
1723 bless $self, "cf::map"; 2397 bless $self, "cf::map::wrap";
1724 delete $self->{deny_reset}; 2398 delete $self->{deny_reset};
1725 $self->{deny_save} = 1; 2399 $self->{deny_save} = 1;
1726 $self->reset_timeout (1); 2400 $self->reset_timeout (1);
1727 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2401 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1728 2402
1729 $cf::MAP{$self->path} = $self; 2403 $cf::MAP{$self->path} = $self;
2404 }
1730 2405
1731 $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 ]
1732} 2443}
1733 2444
1734=item cf::map::unique_maps 2445=item cf::map::unique_maps
1735 2446
1736Returns an arrayref of paths of all shared maps that have 2447Returns an arrayref of paths of all shared maps that have
1737instantiated unique items. May block. 2448instantiated unique items. May block.
1738 2449
1739=cut 2450=cut
1740 2451
1741sub unique_maps() { 2452sub unique_maps() {
1742 my $files = aio_readdir $UNIQUEDIR 2453 [
1743 or return; 2454 map {
1744
1745 my @paths;
1746
1747 for (@$files) {
1748 utf8::decode $_; 2455 utf8::decode $_;
1749 next if /\.pst$/; 2456 s/\.map$//; # TODO future compatibility hack
1750 next unless /^$PATH_SEP/o; 2457 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1751 2458 ? ()
1752 push @paths, cf::map::normalise $_; 2459 : normalise $_
2460 } @{ aio_readdir $UNIQUEDIR or [] }
1753 } 2461 ]
1754
1755 \@paths
1756} 2462}
1757 2463
1758package 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}
1759 2495
1760=back 2496=back
1761 2497
1762=head3 cf::object 2498=head3 cf::object
1763 2499
… …
1767 2503
1768=over 4 2504=over 4
1769 2505
1770=item $ob->inv_recursive 2506=item $ob->inv_recursive
1771 2507
1772Returns 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.
1773 2510
1774=cut 2511=cut
1775 2512
1776sub inv_recursive_; 2513sub inv_recursive_;
1777sub inv_recursive_ { 2514sub inv_recursive_ {
… …
1780 2517
1781sub inv_recursive { 2518sub inv_recursive {
1782 inv_recursive_ inv $_[0] 2519 inv_recursive_ inv $_[0]
1783} 2520}
1784 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
1785package cf; 2550package cf;
1786 2551
1787=back 2552=back
1788 2553
1789=head3 cf::object::player 2554=head3 cf::object::player
… …
1795Sends 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>
1796can 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
1797dialogue with the given NPC character. 2562dialogue with the given NPC character.
1798 2563
1799=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};
1800 2579
1801# rough implementation of a future "reply" method that works 2580# rough implementation of a future "reply" method that works
1802# with dialog boxes. 2581# with dialog boxes.
1803#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
1804sub cf::object::player::reply($$$;$) { 2583sub cf::object::player::reply($$$;$) {
… …
1806 2585
1807 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2586 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1808 2587
1809 if ($self->{record_replies}) { 2588 if ($self->{record_replies}) {
1810 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2589 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2590
1811 } 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 {
1812 $msg = $npc->name . " says: $msg" if $npc; 2599 $msg = $npc->name . " says: $msg" if $npc;
1813 $self->message ($msg, $flags); 2600 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2601 }
1814 } 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 (@_);
1815} 2613}
1816 2614
1817=item $player_object->may ("access") 2615=item $player_object->may ("access")
1818 2616
1819Returns wether the given player is authorized to access resource "access" 2617Returns wether the given player is authorized to access resource "access"
… …
1832 2630
1833=item $player_object->enter_link 2631=item $player_object->enter_link
1834 2632
1835Freezes 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}>).
1836 2634
1837The 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.
1838I<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.
1839 2639
1840Will never block. 2640Will never block.
1841 2641
1842=item $player_object->leave_link ($map, $x, $y) 2642=item $player_object->leave_link ($map, $x, $y)
1843 2643
… …
1863sub cf::object::player::enter_link { 2663sub cf::object::player::enter_link {
1864 my ($self) = @_; 2664 my ($self) = @_;
1865 2665
1866 $self->deactivate_recursive; 2666 $self->deactivate_recursive;
1867 2667
2668 ++$self->{_link_recursion};
2669
1868 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2670 return if UNIVERSAL::isa $self->map, "ext::map_link";
1869 2671
1870 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2672 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1871 if $self->map; 2673 if $self->map && $self->map->{path} ne "{link}";
1872 2674
1873 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2675 $self->enter_map ($LINK_MAP || link_map, 3, 3);
1874} 2676}
1875 2677
1876sub cf::object::player::leave_link { 2678sub cf::object::player::leave_link {
1877 my ($self, $map, $x, $y) = @_; 2679 my ($self, $map, $x, $y) = @_;
2680
2681 return unless $self->contr->active;
1878 2682
1879 my $link_pos = delete $self->{_link_pos}; 2683 my $link_pos = delete $self->{_link_pos};
1880 2684
1881 unless ($map) { 2685 unless ($map) {
1882 # restore original map position 2686 # restore original map position
… …
1893 ($x, $y) = (-1, -1) 2697 ($x, $y) = (-1, -1)
1894 unless (defined $x) && (defined $y); 2698 unless (defined $x) && (defined $y);
1895 2699
1896 # use -1 or undef as default coordinates, not 0, 0 2700 # use -1 or undef as default coordinates, not 0, 0
1897 ($x, $y) = ($map->enter_x, $map->enter_y) 2701 ($x, $y) = ($map->enter_x, $map->enter_y)
1898 if $x <=0 && $y <= 0; 2702 if $x <= 0 && $y <= 0;
1899 2703
1900 $map->load; 2704 $map->load;
1901 $map->load_diag; 2705 $map->load_neighbours;
1902 2706
1903 return unless $self->contr->active; 2707 return unless $self->contr->active;
1904 $self->activate_recursive;
1905 2708
1906 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2709 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1907 $self->enter_map ($map, $x, $y); 2710 if ($self->enter_map ($map, $x, $y)) {
1908} 2711 # entering was successful
1909 2712 delete $self->{_link_recursion};
1910cf::player->attach ( 2713 # only activate afterwards, to support waiting in hooks
1911 on_logout => sub { 2714 $self->activate_recursive;
1912 my ($pl) = @_;
1913
1914 # abort map switching before logout
1915 if ($pl->ob->{_link_pos}) {
1916 cf::sync_job {
1917 $pl->ob->leave_link
1918 };
1919 }
1920 }, 2715 }
1921 on_login => sub {
1922 my ($pl) = @_;
1923 2716
1924 # try to abort aborted map switching on player login :) 2717}
1925 # should happen only on crashes
1926 if ($pl->ob->{_link_pos}) {
1927 $pl->ob->enter_link;
1928 (async {
1929 $pl->ob->reply (undef,
1930 "There was an internal problem at your last logout, "
1931 . "the server will try to bring you to your intended destination in a second.",
1932 cf::NDI_RED);
1933 # we need this sleep as the login has a concurrent enter_exit running
1934 # and this sleep increases chances of the player not ending up in scorn
1935 Coro::Timer::sleep 1;
1936 $pl->ob->leave_link;
1937 })->prio (2);
1938 }
1939 },
1940);
1941 2718
1942=item $player_object->goto ($path, $x, $y) 2719=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
1943 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
1944=cut 2730=cut
2731
2732our $GOTOGEN;
1945 2733
1946sub cf::object::player::goto { 2734sub cf::object::player::goto {
1947 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;
1948 2745
1949 $self->enter_link; 2746 $self->enter_link;
1950 2747
1951 (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
1952 my $map = eval { 2770 my $map = eval {
1953 my $map = cf::map::find $path; 2771 my $map = defined $path ? cf::map::find $path : undef;
2772
2773 if ($map) {
1954 $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
1955 $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 $@;
1956 } or 2786 }
1957 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1958 2787
2788 if ($gen == $self->{_goto_generation}) {
2789 delete $self->{_goto_generation};
1959 $self->leave_link ($map, $x, $y); 2790 $self->leave_link ($map, $x, $y);
2791 }
2792
2793 $done->($self) if $done;
1960 })->prio (1); 2794 })->prio (1);
1961} 2795}
1962 2796
1963=item $player_object->enter_exit ($exit_object) 2797=item $player_object->enter_exit ($exit_object)
1964 2798
… …
1984} 2818}
1985 2819
1986sub prepare_random_map { 2820sub prepare_random_map {
1987 my ($exit) = @_; 2821 my ($exit) = @_;
1988 2822
1989 my $guard = cf::lock_acquire "exit_prepare:$exit";
1990
1991 # all this does is basically replace the /! path by 2823 # all this does is basically replace the /! path by
1992 # a new random map path (?random/...) with a seed 2824 # a new random map path (?random/...) with a seed
1993 # that depends on the exit object 2825 # that depends on the exit object
1994 2826
1995 my $rmp = parse_random_map_params $exit->msg; 2827 my $rmp = parse_random_map_params $exit->msg;
… …
1997 if ($exit->map) { 2829 if ($exit->map) {
1998 $rmp->{region} = $exit->region->name; 2830 $rmp->{region} = $exit->region->name;
1999 $rmp->{origin_map} = $exit->map->path; 2831 $rmp->{origin_map} = $exit->map->path;
2000 $rmp->{origin_x} = $exit->x; 2832 $rmp->{origin_x} = $exit->x;
2001 $rmp->{origin_y} = $exit->y; 2833 $rmp->{origin_y} = $exit->y;
2834
2835 $exit->map->touch;
2002 } 2836 }
2003 2837
2004 $rmp->{random_seed} ||= $exit->random_seed; 2838 $rmp->{random_seed} ||= $exit->random_seed;
2005 2839
2006 my $data = cf::to_json $rmp; 2840 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2007 my $md5 = Digest::MD5::md5_hex $data; 2841 my $md5 = Digest::MD5::md5_hex $data;
2008 my $meta = "$RANDOMDIR/$md5.meta"; 2842 my $meta = "$RANDOMDIR/$md5.meta";
2009 2843
2010 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2844 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2011 aio_write $fh, 0, (length $data), $data, 0; 2845 aio_write $fh, 0, (length $data), $data, 0;
2012 undef $fh; 2846 undef $fh;
2013 aio_rename "$meta~", $meta; 2847 aio_rename "$meta~", $meta;
2014 2848
2849 my $slaying = "?random/$md5";
2850
2851 if ($exit->valid) {
2015 $exit->slaying ("?random/$md5"); 2852 $exit->slaying ("?random/$md5");
2016 $exit->msg (undef); 2853 $exit->msg (undef);
2854 }
2017 } 2855 }
2018} 2856}
2019 2857
2020sub cf::object::player::enter_exit { 2858sub cf::object::player::enter_exit {
2021 my ($self, $exit) = @_; 2859 my ($self, $exit) = @_;
2022 2860
2023 return unless $self->type == cf::PLAYER; 2861 return unless $self->type == cf::PLAYER;
2024 2862
2025 if ($exit->slaying eq "/!") {
2026 #TODO: this should de-fi-ni-te-ly not be a sync-job
2027 # the problem is that $exit might not survive long enough
2028 # so it needs to be done right now, right here
2029 cf::sync_job { prepare_random_map $exit };
2030 }
2031
2032 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2033 my $hp = $exit->stats->hp;
2034 my $sp = $exit->stats->sp;
2035
2036 $self->enter_link; 2863 $self->enter_link;
2037 2864
2038 (async { 2865 (async {
2039 $self->deactivate_recursive; # just to be sure 2866 $Coro::current->{desc} = "enter_exit";
2867
2040 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
2041 $self->goto ($slaying, $hp, $sp); 2883 $self->goto ($map, $x, $y);
2042 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
2043 1; 2889 1
2044 }) { 2890 }) {
2045 $self->message ("Something went wrong deep within the crossfire server. " 2891 $self->message ("Something went wrong deep within the deliantra server. "
2046 . "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. "
2047 . "Please report this to the dungeon master!", 2893 . "Please report this to the dungeon master!",
2048 cf::NDI_UNIQUE | cf::NDI_RED); 2894 cf::NDI_UNIQUE | cf::NDI_RED);
2049 2895
2050 warn "ERROR in enter_exit: $@"; 2896 error "ERROR in enter_exit: $@";
2051 $self->leave_link; 2897 $self->leave_link;
2052 } 2898 }
2053 })->prio (1); 2899 })->prio (1);
2054} 2900}
2055 2901
… …
2069 2915
2070 utf8::encode $text; 2916 utf8::encode $text;
2071 $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);
2072} 2918}
2073 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
2074=item $client->ext_event ($type, %msg) 3107=item $client->ext_msg ($type, @msg)
2075 3108
2076Sends an exti event to the client. 3109Sends an ext event to the client.
2077 3110
2078=cut 3111=cut
2079 3112
2080sub cf::client::ext_event($$%) { 3113sub cf::client::ext_msg($$@) {
2081 my ($self, $type, %msg) = @_; 3114 my ($self, $type, @msg) = @_;
2082 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
2083 $msg{msgtype} = "event_$type"; 3119 push @msg, msgtype => "event_$type";
2084 $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 }
2085} 3140}
2086 3141
2087=item $success = $client->query ($flags, "text", \&cb) 3142=item $success = $client->query ($flags, "text", \&cb)
2088 3143
2089Queues a query to the client, calling the given callback with 3144Queues a query to the client, calling the given callback with
2090the 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>,
2091C<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>.
2092 3147
2093Queries 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
2094reliable at some point in the future. 3149become reliable at some point in the future.
2095 3150
2096=cut 3151=cut
2097 3152
2098sub cf::client::query { 3153sub cf::client::query {
2099 my ($self, $flags, $text, $cb) = @_; 3154 my ($self, $flags, $text, $cb) = @_;
… …
2107 utf8::encode $text; 3162 utf8::encode $text;
2108 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3163 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2109 3164
2110 $self->send_packet ($self->{query_queue}[0][0]) 3165 $self->send_packet ($self->{query_queue}[0][0])
2111 if @{ $self->{query_queue} } == 1; 3166 if @{ $self->{query_queue} } == 1;
3167
3168 1
2112} 3169}
2113 3170
2114cf::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 },
2115 on_reply => sub { 3177 on_reply => sub {
2116 my ($ns, $msg) = @_; 3178 my ($ns, $msg) = @_;
2117 3179
2118 # this weird shuffling is so that direct followup queries 3180 # this weird shuffling is so that direct followup queries
2119 # get handled first 3181 # get handled first
… …
2131 } else { 3193 } else {
2132 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3194 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2133 } 3195 }
2134 } 3196 }
2135 }, 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 },
2136); 3224);
2137 3225
2138=item $client->async (\&cb) 3226=item $client->async (\&cb)
2139 3227
2140Create a new coroutine, running the specified callback. The coroutine will 3228Create a new coroutine, running the specified callback. The coroutine will
… …
2156 3244
2157 $coro 3245 $coro
2158} 3246}
2159 3247
2160cf::client->attach ( 3248cf::client->attach (
2161 on_destroy => sub { 3249 on_client_destroy => sub {
2162 my ($ns) = @_; 3250 my ($ns) = @_;
2163 3251
2164 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3252 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2165 }, 3253 },
2166); 3254);
… …
2181our $safe = new Safe "safe"; 3269our $safe = new Safe "safe";
2182our $safe_hole = new Safe::Hole; 3270our $safe_hole = new Safe::Hole;
2183 3271
2184$SIG{FPE} = 'IGNORE'; 3272$SIG{FPE} = 'IGNORE';
2185 3273
2186$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));
2187 3279
2188# here we export the classes and methods available to script code 3280# here we export the classes and methods available to script code
2189 3281
2190=pod 3282=pod
2191 3283
2192The following functions and methods are available within a safe environment: 3284The following functions and methods are available within a safe environment:
2193 3285
2194 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
2195 cf::object::player player 3291 cf::object::player
2196 cf::player peaceful 3292 player
2197 cf::map trigger 3293
3294 cf::player
3295 peaceful
3296
3297 cf::map
3298 trigger
2198 3299
2199=cut 3300=cut
2200 3301
2201for ( 3302for (
2202 ["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)],
2203 ["cf::object::player" => qw(player)], 3306 ["cf::object::player" => qw(player)],
2204 ["cf::player" => qw(peaceful)], 3307 ["cf::player" => qw(peaceful send_msg)],
2205 ["cf::map" => qw(trigger)], 3308 ["cf::map" => qw(trigger)],
2206) { 3309) {
2207 no strict 'refs';
2208 my ($pkg, @funs) = @$_; 3310 my ($pkg, @funs) = @$_;
2209 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3311 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2210 for @funs; 3312 for @funs;
2211} 3313}
2212 3314
… …
2227 3329
2228 my $qcode = $code; 3330 my $qcode = $code;
2229 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3331 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2230 $qcode =~ s/\n/\\n/g; 3332 $qcode =~ s/\n/\\n/g;
2231 3333
3334 %vars = (_dummy => 0) unless %vars;
3335
3336 my @res;
2232 local $_; 3337 local $_;
2233 local @safe::cf::_safe_eval_args = values %vars;
2234 3338
2235 my $eval = 3339 my $eval =
2236 "do {\n" 3340 "do {\n"
2237 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3341 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2238 . "#line 0 \"{$qcode}\"\n" 3342 . "#line 0 \"{$qcode}\"\n"
2239 . $code 3343 . $code
2240 . "\n}" 3344 . "\n}"
2241 ; 3345 ;
2242 3346
3347 if ($CFG{safe_eval}) {
2243 sub_generation_inc; 3348 sub_generation_inc;
3349 local @safe::cf::_safe_eval_args = values %vars;
2244 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3350 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2245 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 }
2246 3356
2247 if ($@) { 3357 if ($@) {
2248 warn "$@"; 3358 warn "$@",
2249 warn "while executing safe code '$code'\n"; 3359 "while executing safe code '$code'\n",
2250 warn "with arguments " . (join " ", %vars) . "\n"; 3360 "with arguments " . (join " ", %vars) . "\n";
2251 } 3361 }
2252 3362
2253 wantarray ? @res : $res[0] 3363 wantarray ? @res : $res[0]
2254} 3364}
2255 3365
… …
2269=cut 3379=cut
2270 3380
2271sub register_script_function { 3381sub register_script_function {
2272 my ($fun, $cb) = @_; 3382 my ($fun, $cb) = @_;
2273 3383
2274 no strict 'refs'; 3384 $fun = "safe::$fun" if $CFG{safe_eval};
2275 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3385 *$fun = $safe_hole->wrap ($cb);
2276} 3386}
2277 3387
2278=back 3388=back
2279 3389
2280=cut 3390=cut
2281
2282#############################################################################
2283
2284=head2 EXTENSION DATABASE SUPPORT
2285
2286Crossfire maintains a very simple database for extension use. It can
2287currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2288convert to/from binary).
2289
2290The parameter C<$family> should best start with the name of the extension
2291using it, it should be unique.
2292
2293=over 4
2294
2295=item $value = cf::db_get $family => $key
2296
2297Returns a single value from the database.
2298
2299=item cf::db_put $family => $key => $value
2300
2301Stores the given C<$value> in the family.
2302
2303=cut
2304
2305our $DB;
2306
2307sub db_init {
2308 unless ($DB) {
2309 $DB = BDB::db_create $DB_ENV;
2310
2311 cf::sync_job {
2312 eval {
2313 $DB->set_flags (BDB::CHKSUM);
2314
2315 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2316 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2317 cf::cleanup "db_open(db): $!" if $!;
2318 };
2319 cf::cleanup "db_open(db): $@" if $@;
2320 };
2321 }
2322}
2323
2324sub db_get($$) {
2325 my $key = "$_[0]/$_[1]";
2326
2327 cf::sync_job {
2328 BDB::db_get $DB, undef, $key, my $data;
2329
2330 $! ? ()
2331 : $data
2332 }
2333}
2334
2335sub db_put($$$) {
2336 BDB::dbreq_pri 4;
2337 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2338}
2339
2340=item cf::cache $id => [$paths...], $processversion => $process
2341
2342Generic caching function that returns the value of the resource $id,
2343caching and regenerating as required.
2344
2345This function can block.
2346
2347=cut
2348
2349sub cache {
2350 my ($id, $src, $processversion, $process) = @_;
2351
2352 my $meta =
2353 join "\x00",
2354 $processversion,
2355 map {
2356 aio_stat $_
2357 and Carp::croak "$_: $!";
2358
2359 ($_, (stat _)[7,9])
2360 } @$src;
2361
2362 my $dbmeta = db_get cache => "$id/meta";
2363 if ($dbmeta ne $meta) {
2364 # changed, we may need to process
2365
2366 my @data;
2367 my $md5;
2368
2369 for (0 .. $#$src) {
2370 0 <= aio_load $src->[$_], $data[$_]
2371 or Carp::croak "$src->[$_]: $!";
2372 }
2373
2374 # if processing is expensive, check
2375 # checksum first
2376 if (1) {
2377 $md5 =
2378 join "\x00",
2379 $processversion,
2380 map {
2381 Coro::cede;
2382 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2383 } 0.. $#$src;
2384
2385
2386 my $dbmd5 = db_get cache => "$id/md5";
2387 if ($dbmd5 eq $md5) {
2388 db_put cache => "$id/meta", $meta;
2389
2390 return db_get cache => "$id/data";
2391 }
2392 }
2393
2394 my $t1 = Time::HiRes::time;
2395 my $data = $process->(\@data);
2396 my $t2 = Time::HiRes::time;
2397
2398 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2399
2400 db_put cache => "$id/data", $data;
2401 db_put cache => "$id/md5" , $md5;
2402 db_put cache => "$id/meta", $meta;
2403
2404 return $data;
2405 }
2406
2407 db_get cache => "$id/data"
2408}
2409
2410=item fork_call { }, $args
2411
2412Executes the given code block with the given arguments in a seperate
2413process, returning the results. Everything must be serialisable with
2414Coro::Storable. May, of course, block. Note that the executed sub may
2415never block itself or use any form of Event handling.
2416
2417=cut
2418
2419sub fork_call(&@) {
2420 my ($cb, @args) = @_;
2421
2422# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2423# or die "socketpair: $!";
2424 pipe my $fh1, my $fh2
2425 or die "pipe: $!";
2426
2427 if (my $pid = fork) {
2428 close $fh2;
2429
2430 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2431 $res = Coro::Storable::thaw $res;
2432
2433 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2434
2435 die $$res unless "ARRAY" eq ref $res;
2436
2437 return wantarray ? @$res : $res->[-1];
2438 } else {
2439 local $SIG{__WARN__};
2440 eval {
2441 local $SIG{__DIE__};
2442 close $fh1;
2443
2444 my @res = eval { $cb->(@args) };
2445 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2446 };
2447
2448 warn $@ if $@;
2449 _exit 0;
2450 }
2451}
2452
2453
2454 3391
2455############################################################################# 3392#############################################################################
2456# the server's init and main functions 3393# the server's init and main functions
2457 3394
2458sub load_facedata($) { 3395sub load_facedata($) {
2459 my ($path) = @_; 3396 my ($path) = @_;
2460 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
2461 warn "loading facedata from $path\n"; 3404 trace "loading facedata from $path\n";
2462 3405
2463 my $facedata;
2464 0 < aio_load $path, $facedata 3406 0 < aio_load $path, my $facedata
2465 or die "$path: $!"; 3407 or die "$path: $!";
2466 3408
2467 $facedata = Coro::Storable::thaw $facedata; 3409 $facedata = Coro::Storable::thaw $facedata;
2468 3410
2469 $facedata->{version} == 2 3411 $facedata->{version} == 2
2470 or cf::cleanup "$path: version mismatch, cannot proceed."; 3412 or cf::cleanup "$path: version mismatch, cannot proceed.";
2471 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
2472 { 3423 {
2473 my $faces = $facedata->{faceinfo}; 3424 my $faces = $facedata->{faceinfo};
2474 3425
2475 while (my ($face, $info) = each %$faces) { 3426 while (my ($face, $info) = each %$faces) {
2476 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3427 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3428
2477 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3429 cf::face::set_visibility $idx, $info->{visibility};
3430 cf::face::set_magicmap $idx, $info->{magicmap};
2478 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3431 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2479 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3432 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2480 Coro::cede; 3433 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3434
3435 cf::cede_to_tick;
2481 } 3436 }
2482 3437
2483 while (my ($face, $info) = each %$faces) { 3438 while (my ($face, $info) = each %$faces) {
2484 next unless $info->{smooth}; 3439 next unless $info->{smooth};
3440
2485 my $idx = cf::face::find $face 3441 my $idx = cf::face::find $face
2486 or next; 3442 or next;
3443
2487 if (my $smooth = cf::face::find $info->{smooth}) { 3444 if (my $smooth = cf::face::find $info->{smooth}) {
3445 cf::face::set_smooth $idx, $smooth;
2488 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3446 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2489 } else { 3447 } else {
2490 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3448 error "smooth face '$info->{smooth}' not found for face '$face'";
2491 } 3449 }
2492 Coro::cede; 3450
3451 cf::cede_to_tick;
2493 } 3452 }
2494 } 3453 }
2495 3454
2496 { 3455 {
2497 my $anims = $facedata->{animinfo}; 3456 my $anims = $facedata->{animinfo};
2498 3457
2499 while (my ($anim, $info) = each %$anims) { 3458 while (my ($anim, $info) = each %$anims) {
2500 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3459 cf::anim::set $anim, $info->{frames}, $info->{facings};
2501 Coro::cede; 3460 cf::cede_to_tick;
2502 } 3461 }
2503 3462
2504 cf::anim::invalidate_all; # d'oh 3463 cf::anim::invalidate_all; # d'oh
2505 } 3464 }
2506 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
2507 1 3485 1
2508} 3486}
2509 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
2510sub 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
2511 load_resource_file "$MAPDIR/regions" 3511 load_resource_file "$MAPDIR/regions"
2512 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 }
2513} 3518}
2514 3519
2515sub reload_facedata { 3520sub reload_facedata {
2516 load_facedata "$DATADIR/facedata" 3521 load_facedata "$DATADIR/facedata"
2517 or die "unable to load facedata\n"; 3522 or die "unable to load facedata\n";
… …
2525sub reload_treasures { 3530sub reload_treasures {
2526 load_resource_file "$DATADIR/treasures" 3531 load_resource_file "$DATADIR/treasures"
2527 or die "unable to load treasurelists\n"; 3532 or die "unable to load treasurelists\n";
2528} 3533}
2529 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
2530sub reload_resources { 3558sub reload_resources {
2531 warn "reloading resource files...\n"; 3559 trace "reloading resource files...\n";
2532 3560
3561 reload_exp_table;
3562 reload_materials;
3563 reload_facedata;
3564 reload_sound;
3565 reload_archetypes;
2533 reload_regions; 3566 reload_regions;
2534 reload_facedata;
2535 reload_archetypes;
2536 reload_treasures; 3567 reload_treasures;
2537 3568
2538 warn "finished reloading resource files\n"; 3569 trace "finished reloading resource files\n";
2539} 3570}
2540 3571
2541sub init { 3572sub reload_config {
2542 reload_resources; 3573 trace "reloading config file...\n";
2543}
2544 3574
2545sub cfg_load { 3575 0 < aio_load "$CONFDIR/config", my $config
2546 open my $fh, "<:utf8", "$CONFDIR/config" 3576 or die "$CONFDIR/config: $!";
2547 or return;
2548 3577
2549 local $/; 3578 utf8::decode $config;
2550 *CFG = YAML::Syck::Load <$fh>; 3579 *CFG = yaml_load $config;
2551 3580
2552 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3581 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
2553 3582
2554 $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};
2555 $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};
2556 3585
2557 if (exists $CFG{mlockall}) { 3586 if (exists $CFG{mlockall}) {
… …
2561 }; 3590 };
2562 warn $@ if $@; 3591 warn $@ if $@;
2563 } 3592 }
2564} 3593}
2565 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
2566sub 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
2567 # we must not ever block the main coroutine 3633 # we must not ever block the main coroutine
2568 local $Coro::idle = sub { 3634 local $Coro::idle = sub {
2569 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#
2570 (async { 3636 (async {
2571 Event::one_event; 3637 $Coro::current->{desc} = "IDLE BUG HANDLER";
3638 EV::loop EV::LOOP_ONESHOT;
2572 })->prio (Coro::PRIO_MAX); 3639 })->prio (Coro::PRIO_MAX);
2573 }; 3640 };
2574 3641
2575 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;
2576 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
2577 load_extensions; 3665 load_extensions;
2578 3666
2579 $TICK_WATCHER->start; 3667 utime time, time, $RUNTIMEFILE;
2580 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;
2581} 3685}
2582 3686
2583############################################################################# 3687#############################################################################
2584# initialisation and cleanup 3688# initialisation and cleanup
2585 3689
2586# install some emergency cleanup handlers 3690# install some emergency cleanup handlers
2587BEGIN { 3691BEGIN {
3692 our %SIGWATCHER = ();
2588 for my $signal (qw(INT HUP TERM)) { 3693 for my $signal (qw(INT HUP TERM)) {
2589 Event->signal ( 3694 $SIGWATCHER{$signal} = AE::signal $signal, sub {
2590 reentrant => 0,
2591 data => WF_AUTOCANCEL,
2592 signal => $signal,
2593 prio => 0,
2594 cb => sub {
2595 cf::cleanup "SIG$signal"; 3695 cf::cleanup "SIG$signal";
2596 },
2597 ); 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
2598 } 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 };
2599} 3786}
2600 3787
2601sub emergency_save() { 3788sub emergency_save() {
2602 my $freeze_guard = cf::freeze_mainloop; 3789 my $freeze_guard = cf::freeze_mainloop;
2603 3790
2604 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;
2605 3797
2606 cf::sync_job { 3798 cf::sync_job {
3799 cf::write_runtime_sync; # external watchdog should not bark
3800
2607 # use a peculiar iteration method to avoid tripping on perl 3801 # use a peculiar iteration method to avoid tripping on perl
2608 # refcount bugs in for. also avoids problems with players 3802 # refcount bugs in for. also avoids problems with players
2609 # and maps saved/destroyed asynchronously. 3803 # and maps saved/destroyed asynchronously.
2610 warn "begin emergency player save\n"; 3804 info "emergency_perl_save: begin player save\n";
2611 for my $login (keys %cf::PLAYER) { 3805 for my $login (keys %cf::PLAYER) {
2612 my $pl = $cf::PLAYER{$login} or next; 3806 my $pl = $cf::PLAYER{$login} or next;
2613 $pl->valid or next; 3807 $pl->valid or next;
3808 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2614 $pl->save; 3809 $pl->save;
2615 } 3810 }
2616 warn "end emergency player save\n"; 3811 info "emergency_perl_save: end player save\n";
2617 3812
2618 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";
2619 for my $path (keys %cf::MAP) { 3816 for my $path (keys %cf::MAP) {
2620 my $map = $cf::MAP{$path} or next; 3817 my $map = $cf::MAP{$path} or next;
2621 $map->valid or next; 3818 $map->valid or next;
2622 $map->save; 3819 $map->save;
2623 } 3820 }
2624 warn "end emergency map save\n"; 3821 info "emergency_perl_save: end map save\n";
2625 3822
2626 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";
2627 BDB::db_env_txn_checkpoint $DB_ENV; 3826 BDB::db_env_txn_checkpoint $DB_ENV;
2628 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
2629 }; 3851 };
2630 3852
2631 warn "leave emergency perl save\n"; 3853 info "emergency_perl_save: leave\n";
2632} 3854}
2633 3855
2634sub post_cleanup { 3856sub post_cleanup {
2635 my ($make_core) = @_; 3857 my ($make_core) = @_;
2636 3858
3859 IO::AIO::flush;
3860
2637 warn Carp::longmess "post_cleanup backtrace" 3861 error Carp::longmess "post_cleanup backtrace"
2638 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 }
2639} 3891}
2640 3892
2641sub do_reload_perl() { 3893sub do_reload_perl() {
2642 # can/must only be called in main 3894 # can/must only be called in main
2643 if ($Coro::current != $Coro::main) { 3895 unless (in_main) {
2644 warn "can only reload from main coroutine"; 3896 error "can only reload from main coroutine";
2645 return; 3897 return;
2646 } 3898 }
2647 3899
2648 warn "reloading..."; 3900 return if $RELOAD++;
2649 3901
2650 warn "entering sync_job"; 3902 my $t1 = AE::time;
2651 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
2652 cf::sync_job { 3910 cf::sync_job {
2653 cf::write_runtime; # external watchdog should not bark
2654 cf::emergency_save; 3911 #cf::emergency_save;
2655 cf::write_runtime; # external watchdog should not bark
2656 3912
2657 warn "syncing database to disk";
2658 BDB::db_env_txn_checkpoint $DB_ENV;
2659
2660 # if anything goes wrong in here, we should simply crash as we already saved
2661
2662 warn "cancelling all WF_AUTOCANCEL watchers";
2663 for (Event::all_watchers) {
2664 $_->cancel if $_->data & WF_AUTOCANCEL;
2665 }
2666
2667 warn "flushing outstanding aio requests";
2668 for (;;) {
2669 BDB::flush;
2670 IO::AIO::flush;
2671 Coro::cede;
2672 last unless IO::AIO::nreqs || BDB::nreqs;
2673 warn "iterate...";
2674 }
2675
2676 ++$RELOAD;
2677
2678 warn "cancelling all extension coros"; 3913 trace "perl_reload: cancelling all extension coros";
2679 $_->cancel for values %EXT_CORO; 3914 $_->cancel for values %EXT_CORO;
2680 %EXT_CORO = (); 3915 %EXT_CORO = ();
2681 3916
2682 warn "removing commands"; 3917 trace "perl_reload: removing commands";
2683 %COMMAND = (); 3918 %COMMAND = ();
2684 3919
2685 warn "removing ext commands"; 3920 trace "perl_reload: removing ext/exti commands";
2686 %EXTCMD = (); 3921 %EXTCMD = ();
3922 %EXTICMD = ();
2687 3923
2688 warn "unloading/nuking all extensions"; 3924 trace "perl_reload: unloading/nuking all extensions";
2689 for my $pkg (@EXTS) { 3925 for my $pkg (@EXTS) {
2690 warn "... unloading $pkg"; 3926 trace "... unloading $pkg";
2691 3927
2692 if (my $cb = $pkg->can ("unload")) { 3928 if (my $cb = $pkg->can ("unload")) {
2693 eval { 3929 eval {
2694 $cb->($pkg); 3930 $cb->($pkg);
2695 1 3931 1
2696 } 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;
2697 } 3937 }
2698 3938
2699 warn "... nuking $pkg";
2700 Symbol::delete_package $pkg;
2701 }
2702
2703 warn "unloading all perl modules loaded from $LIBDIR"; 3939 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
2704 while (my ($k, $v) = each %INC) { 3940 while (my ($k, $v) = each %INC) {
2705 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3941 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2706 3942
2707 warn "... unloading $k"; 3943 trace "... unloading $k";
2708 delete $INC{$k}; 3944 delete $INC{$k};
2709 3945
2710 $k =~ s/\.pm$//; 3946 $k =~ s/\.pm$//;
2711 $k =~ s/\//::/g; 3947 $k =~ s/\//::/g;
2712 3948
2713 if (my $cb = $k->can ("unload_module")) { 3949 if (my $cb = $k->can ("unload_module")) {
2714 $cb->(); 3950 $cb->();
3951 }
3952
3953 clear_package $k;
2715 } 3954 }
2716 3955
2717 Symbol::delete_package $k;
2718 }
2719
2720 warn "getting rid of safe::, as good as possible"; 3956 trace "perl_reload: getting rid of safe::, as good as possible";
2721 Symbol::delete_package "safe::$_" 3957 clear_package "safe::$_"
2722 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);
2723 3959
2724 warn "unloading cf.pm \"a bit\""; 3960 trace "perl_reload: unloading cf.pm \"a bit\"";
2725 delete $INC{"cf.pm"}; 3961 delete $INC{"cf.pm"};
2726 delete $INC{"cf/pod.pm"}; 3962 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2727 3963
2728 # don't, removes xs symbols, too, 3964 # don't, removes xs symbols, too,
2729 # and global variables created in xs 3965 # and global variables created in xs
2730 #Symbol::delete_package __PACKAGE__; 3966 #clear_package __PACKAGE__;
2731 3967
2732 warn "unload completed, starting to reload now"; 3968 info "perl_reload: unload completed, starting to reload now";
2733 3969
2734 warn "reloading cf.pm"; 3970 trace "perl_reload: reloading cf.pm";
2735 require cf; 3971 require cf;
2736 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3972 cf::_connect_to_perl_1;
2737 3973
2738 warn "loading config and database again"; 3974 trace "perl_reload: loading config and database again";
2739 cf::cfg_load; 3975 cf::reload_config;
2740 3976
2741 warn "loading extensions"; 3977 trace "perl_reload: loading extensions";
2742 cf::load_extensions; 3978 cf::load_extensions;
2743 3979
3980 if ($REATTACH_ON_RELOAD) {
2744 warn "reattaching attachments to objects/players"; 3981 trace "perl_reload: reattaching attachments to objects/players";
2745 _global_reattach; # objects, sockets 3982 _global_reattach; # objects, sockets
2746 warn "reattaching attachments to maps"; 3983 trace "perl_reload: reattaching attachments to maps";
2747 reattach $_ for values %MAP; 3984 reattach $_ for values %MAP;
2748 warn "reattaching attachments to players"; 3985 trace "perl_reload: reattaching attachments to players";
2749 reattach $_ for values %PLAYER; 3986 reattach $_ for values %PLAYER;
3987 }
2750 3988
2751 warn "leaving sync_job"; 3989 cf::_post_init 1;
2752 3990
3991 trace "perl_reload: leaving sync_job";
3992
2753 1 3993 1
2754 } or do { 3994 } or do {
2755 warn $@; 3995 error $@;
2756 warn "error while reloading, exiting."; 3996 cf::cleanup "perl_reload: error, exiting.";
2757 exit 1; 3997 };
3998
3999 --$RELOAD;
2758 }; 4000 }
2759 4001
2760 warn "reloaded"; 4002 $t1 = AE::time - $t1;
4003 info "perl_reload: completed in ${t1}s\n";
2761}; 4004};
2762 4005
2763our $RELOAD_WATCHER; # used only during reload 4006our $RELOAD_WATCHER; # used only during reload
2764 4007
2765sub reload_perl() { 4008sub reload_perl() {
2766 # doing reload synchronously and two reloads happen back-to-back, 4009 # doing reload synchronously and two reloads happen back-to-back,
2767 # coro crashes during coro_state_free->destroy here. 4010 # coro crashes during coro_state_free->destroy here.
2768 4011
2769 $RELOAD_WATCHER ||= Event->timer ( 4012 $RELOAD_WATCHER ||= cf::async {
2770 reentrant => 0, 4013 Coro::AIO::aio_wait cache_extensions;
2771 after => 0, 4014
2772 data => WF_AUTOCANCEL, 4015 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
2773 cb => sub {
2774 do_reload_perl; 4016 do_reload_perl;
2775 undef $RELOAD_WATCHER; 4017 undef $RELOAD_WATCHER;
2776 }, 4018 };
2777 ); 4019 };
2778} 4020}
2779 4021
2780register_command "reload" => sub { 4022register_command "reload" => sub {
2781 my ($who, $arg) = @_; 4023 my ($who, $arg) = @_;
2782 4024
2783 if ($who->flag (FLAG_WIZ)) { 4025 if ($who->flag (FLAG_WIZ)) {
2784 $who->message ("reloading server."); 4026 $who->message ("reloading server.");
4027 async {
4028 $Coro::current->{desc} = "perl_reload";
2785 async { reload_perl }; 4029 reload_perl;
4030 };
2786 } 4031 }
2787}; 4032};
2788 4033
2789unshift @INC, $LIBDIR; 4034#############################################################################
2790 4035
2791my $bug_warning = 0; 4036my $bug_warning = 0;
2792 4037
2793our @WAIT_FOR_TICK; 4038our @WAIT_FOR_TICK;
2794our @WAIT_FOR_TICK_BEGIN; 4039our @WAIT_FOR_TICK_BEGIN;
2795 4040
2796sub wait_for_tick { 4041sub wait_for_tick() {
2797 return unless $TICK_WATCHER->is_active;
2798 return if $Coro::current == $Coro::main; 4042 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2799 4043
2800 my $signal = new Coro::Signal; 4044 my $signal = new Coro::Signal;
2801 push @WAIT_FOR_TICK, $signal; 4045 push @WAIT_FOR_TICK, $signal;
2802 $signal->wait; 4046 $signal->wait;
2803} 4047}
2804 4048
2805sub wait_for_tick_begin { 4049sub wait_for_tick_begin() {
2806 return unless $TICK_WATCHER->is_active;
2807 return if $Coro::current == $Coro::main; 4050 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2808 4051
2809 my $signal = new Coro::Signal; 4052 my $signal = new Coro::Signal;
2810 push @WAIT_FOR_TICK_BEGIN, $signal; 4053 push @WAIT_FOR_TICK_BEGIN, $signal;
2811 $signal->wait; 4054 $signal->wait;
2812} 4055}
2813 4056
2814$TICK_WATCHER = Event->timer ( 4057sub tick {
2815 reentrant => 0,
2816 parked => 1,
2817 prio => 0,
2818 at => $NEXT_TICK || $TICK,
2819 data => WF_AUTOCANCEL,
2820 cb => sub {
2821 if ($Coro::current != $Coro::main) { 4058 if ($Coro::current != $Coro::main) {
2822 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"
2823 unless ++$bug_warning > 10; 4060 unless ++$bug_warning > 10;
2824 return; 4061 return;
2825 } 4062 }
2826 4063
2827 $NOW = Event::time;
2828
2829 cf::server_tick; # one server iteration 4064 cf::server_tick; # one server iteration
2830 4065
2831 $RUNTIME += $TICK; 4066 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
2832 $NEXT_TICK += $TICK;
2833 4067
2834 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4068 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2835 $NEXT_RUNTIME_WRITE = $NOW + 10; 4069 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2836 Coro::async_pool { 4070 Coro::async_pool {
4071 $Coro::current->{desc} = "runtime saver";
2837 write_runtime 4072 write_runtime_sync
2838 or warn "ERROR: unable to write runtime file: $!"; 4073 or error "ERROR: unable to write runtime file: $!";
2839 };
2840 } 4074 };
4075 }
2841 4076
2842# my $AFTER = Event::time;
2843# warn $AFTER - $NOW;#d#
2844
2845 # if we are delayed by four ticks or more, skip them all
2846 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2847
2848 $TICK_WATCHER->at ($NEXT_TICK);
2849 $TICK_WATCHER->start;
2850
2851 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4077 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2852 $sig->send; 4078 $sig->send;
2853 } 4079 }
2854 while (my $sig = shift @WAIT_FOR_TICK) { 4080 while (my $sig = shift @WAIT_FOR_TICK) {
2855 $sig->send; 4081 $sig->send;
2856 }
2857
2858 _post_tick;
2859 }, 4082 }
2860); 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}
2861 4095
2862{ 4096{
2863 BDB::max_poll_time $TICK * 0.1; 4097 # configure BDB
2864 $BDB_POLL_WATCHER = Event->io ( 4098
2865 reentrant => 0,
2866 fd => BDB::poll_fileno,
2867 poll => 'r',
2868 prio => 0,
2869 data => WF_AUTOCANCEL,
2870 cb => \&BDB::poll_cb,
2871 );
2872 BDB::min_parallel 8; 4099 BDB::min_parallel 16;
2873 4100 BDB::max_poll_reqs $TICK * 0.1;
2874 BDB::set_sync_prepare { 4101 $AnyEvent::BDB::WATCHER->priority (1);
2875 my $status;
2876 my $current = $Coro::current;
2877 (
2878 sub {
2879 $status = $!;
2880 $current->ready; undef $current;
2881 },
2882 sub {
2883 Coro::schedule while defined $current;
2884 $! = $status;
2885 },
2886 )
2887 };
2888 4102
2889 unless ($DB_ENV) { 4103 unless ($DB_ENV) {
2890 $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);
2891 4110
2892 cf::sync_job { 4111 cf::sync_job {
2893 eval { 4112 eval {
2894 BDB::db_env_open 4113 BDB::db_env_open
2895 $DB_ENV, 4114 $DB_ENV,
… …
2897 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
2898 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4117 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2899 0666; 4118 0666;
2900 4119
2901 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4120 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2902
2903 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2904 $DB_ENV->set_lk_detect;
2905 }; 4121 };
2906 4122
2907 cf::cleanup "db_env_open(db): $@" if $@; 4123 cf::cleanup "db_env_open(db): $@" if $@;
2908 }; 4124 };
2909 } 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 };
2910} 4136}
2911 4137
2912{ 4138{
4139 # configure IO::AIO
4140
2913 IO::AIO::min_parallel 8; 4141 IO::AIO::min_parallel 8;
2914
2915 undef $Coro::AIO::WATCHER;
2916 IO::AIO::max_poll_time $TICK * 0.1; 4142 IO::AIO::max_poll_time $TICK * 0.1;
2917 $AIO_POLL_WATCHER = Event->io ( 4143 undef $AnyEvent::AIO::WATCHER;
2918 reentrant => 0, 4144}
2919 data => WF_AUTOCANCEL, 4145
2920 fd => IO::AIO::poll_fileno, 4146our $_log_backtrace;
2921 poll => 'r', 4147our $_log_backtrace_last;
2922 prio => 6, 4148
2923 cb => \&IO::AIO::poll_cb, 4149sub _log_backtrace {
2924 ); 4150 my ($msg, @addr) = @_;
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;
4162 async {
4163 $Coro::current->{desc} = "abt $msg";
4164
4165 my @bt = fork_call {
4166 @addr = map { sprintf "%x", $_ } @addr;
4167 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
4168 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
4169 or die "addr2line: $!";
4170
4171 my @funcs;
4172 my @res = <$fh>;
4173 chomp for @res;
4174 while (@res) {
4175 my ($func, $line) = splice @res, 0, 2, ();
4176 push @funcs, "[$func] $line";
4177 }
4178
4179 @funcs
4180 };
4181
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;
4186 };
4187 } else {
4188 LOG llevInfo, "[ABT] $msg\n";
4189 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4190 }
2925} 4191}
2926 4192
2927# load additional modules 4193# load additional modules
2928use cf::pod; 4194require "cf/$_.pm" for @EXTRA_MODULES;
4195cf::_connect_to_perl_2;
2929 4196
2930END { cf::emergency_save } 4197END { cf::emergency_save }
2931 4198
29321 41991
2933 4200

Diff Legend

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