ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/lib/cf.pm
(Generate patch)

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.263 by root, Sat May 5 05:40:27 2007 UTC vs.
Revision 1.559 by root, Sat Feb 26 12:50:27 2011 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
3use utf8; 25use common::sense;
4use strict;
5 26
6use Symbol; 27use Symbol;
7use List::Util; 28use List::Util;
8use Socket; 29use Socket;
9use Storable; 30use EV;
10use Event;
11use Opcode; 31use Opcode;
12use Safe; 32use Safe;
13use Safe::Hole; 33use Safe::Hole;
34use Storable ();
35use Carp ();
14 36
37use Guard ();
15use Coro 3.61 (); 38use Coro ();
16use Coro::State; 39use Coro::State;
17use Coro::Handle; 40use Coro::Handle;
41use Coro::EV;
18use Coro::Event; 42use Coro::AnyEvent;
19use Coro::Timer; 43use Coro::Timer;
20use Coro::Signal; 44use Coro::Signal;
21use Coro::Semaphore; 45use Coro::Semaphore;
46use Coro::SemaphoreSet;
47use Coro::AnyEvent;
22use Coro::AIO; 48use Coro::AIO;
49use Coro::BDB 1.6;
23use Coro::Storable; 50use Coro::Storable;
51use Coro::Util ();
24 52
53use JSON::XS 2.01 ();
25use BDB (); 54use BDB ();
26use Data::Dumper; 55use Data::Dumper;
27use Digest::MD5;
28use Fcntl; 56use Fcntl;
29use YAML::Syck (); 57use YAML::XS ();
30use IO::AIO 2.32 (); 58use IO::AIO ();
31use Time::HiRes; 59use Time::HiRes;
32use Compress::LZF; 60use Compress::LZF;
61use Digest::MD5 ();
62
63AnyEvent::detect;
33 64
34# configure various modules to our taste 65# configure various modules to our taste
35# 66#
36$Storable::canonical = 1; # reduce rsync transfers 67$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 68Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
69
70$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71
72# make sure c-lzf reinitialises itself
73Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 74Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39 75
40$Event::Eval = 1; # no idea why this is required, but it is 76# strictly for debugging
41 77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
43$YAML::Syck::ImplicitUnicode = 1;
44
45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46 78
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
80
81our @ORIG_INC;
48 82
49our %COMMAND = (); 83our %COMMAND = ();
50our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
51 85
52our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 87our %EXTCMD = ();
88our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
56 91
57our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
58our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
59 96
60our $CONFDIR = confdir; 97our $CONFDIR = confdir;
98
61our $DATADIR = datadir; 99our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
103
65our $LOCALDIR = localdir; 104our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir; 105our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 106our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir; 107our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random"; 108our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db"; 109our $BDBDIR = "$LOCALDIR/db";
110our $PIDFILE = "$LOCALDIR/pid";
111our $RUNTIMEFILE = "$LOCALDIR/runtime";
112
113our %RESOURCE; # unused
114
115our $OUTPUT_RATE_MIN = 3000;
116our $OUTPUT_RATE_MAX = 1000000;
117
118our $MAX_LINKS = 32; # how many chained exits to follow
119our $VERBOSE_IO = 1;
71 120
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 121our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 122our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
76our $NEXT_TICK; 123our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 124our $USE_FSYNC = 1; # use fsync to write maps - default on
79 125
126our $BDB_DEADLOCK_WATCHER;
127our $BDB_CHECKPOINT_WATCHER;
80our $BDB_POLL_WATCHER; 128our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 129our $DB_ENV;
130
131our @EXTRA_MODULES = qw(pod match mapscript incloader);
82 132
83our %CFG; 133our %CFG;
84 134
85our $UPTIME; $UPTIME ||= time; 135our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 136our $RUNTIME;
137our $NOW;
87 138
88our %PLAYER; # all users 139our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 140our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 141our $LINK_MAP; # the special {link} map, which is always available
91 142
92# used to convert map paths into valid unix filenames by replacing / by ∕ 143# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 144our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 145
146our $LOAD; # a number between 0 (idle) and 1 (too many objects)
147our $LOADAVG; # same thing, but with alpha-smoothing
148our $JITTER; # average jitter
149our $TICK_START; # for load detecting purposes
150
151our @POST_INIT;
152
153our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
154our $REALLY_UNLOOP; # never set to true, please :)
155
95binmode STDOUT; 156binmode STDOUT;
96binmode STDERR; 157binmode STDERR;
97 158
98# read virtual server time, if available 159# read virtual server time, if available
99unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 160unless ($RUNTIME || !-e $RUNTIMEFILE) {
100 open my $fh, "<", "$LOCALDIR/runtime" 161 open my $fh, "<", $RUNTIMEFILE
101 or die "unable to read runtime file: $!"; 162 or die "unable to read $RUNTIMEFILE file: $!";
102 $RUNTIME = <$fh> + 0.; 163 $RUNTIME = <$fh> + 0.;
103} 164}
165
166eval "sub TICK() { $TICK } 1" or die;
104 167
105mkdir $_ 168mkdir $_
106 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 169 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
107 170
108our $EMERGENCY_POSITION; 171our $EMERGENCY_POSITION;
109 172
110sub cf::map::normalise; 173sub cf::map::normalise;
174
175sub in_main() {
176 $Coro::current == $Coro::main
177}
178
179#############################################################################
180
181%REFLECT = ();
182for (@REFLECT) {
183 my $reflect = JSON::XS::decode_json $_;
184 $REFLECT{$reflect->{class}} = $reflect;
185}
186
187# this is decidedly evil
188$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
111 189
112############################################################################# 190#############################################################################
113 191
114=head2 GLOBAL VARIABLES 192=head2 GLOBAL VARIABLES
115 193
… …
139 217
140=item $cf::TICK 218=item $cf::TICK
141 219
142The interval between server ticks, in seconds. 220The interval between server ticks, in seconds.
143 221
222=item $cf::LOADAVG
223
224The current CPU load on the server (alpha-smoothed), as a value between 0
225(none) and 1 (overloaded), indicating how much time is spent on processing
226objects per tick. Healthy values are < 0.5.
227
228=item $cf::LOAD
229
230The raw value load value from the last tick.
231
144=item %cf::CFG 232=item %cf::CFG
145 233
146Configuration for the server, loaded from C</etc/crossfire/config>, or 234Configuration for the server, loaded from C</etc/deliantra-server/config>, or
147from wherever your confdir points to. 235from wherever your confdir points to.
148 236
149=item cf::wait_for_tick, cf::wait_for_tick_begin 237=item cf::wait_for_tick, cf::wait_for_tick_begin
150 238
151These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 239These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
152returns directly I<after> the tick processing (and consequently, can only wake one process 240returns directly I<after> the tick processing (and consequently, can only wake one thread
153per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 241per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
154 242
243=cut
244
245sub wait_for_tick();
246sub wait_for_tick_begin();
247
248=item @cf::INVOKE_RESULTS
249
250This array contains the results of the last C<invoke ()> call. When
251C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
252that call.
253
254=item %cf::REFLECT
255
256Contains, for each (C++) class name, a hash reference with information
257about object members (methods, scalars, arrays and flags) and other
258metadata, which is useful for introspection.
259
155=back 260=back
156 261
157=cut 262=cut
158 263
159BEGIN { 264sub error(@) { LOG llevError, join "", @_ }
160 *CORE::GLOBAL::warn = sub { 265sub warn (@) { LOG llevWarn , join "", @_ }
266sub info (@) { LOG llevInfo , join "", @_ }
267sub debug(@) { LOG llevDebug, join "", @_ }
268sub trace(@) { LOG llevTrace, join "", @_ }
269
270$Coro::State::WARNHOOK = sub {
161 my $msg = join "", @_; 271 my $msg = join "", @_;
162 272
163 $msg .= "\n" 273 $msg .= "\n"
164 unless $msg =~ /\n$/; 274 unless $msg =~ /\n$/;
165 275
166 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 276 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
167 277
168 utf8::encode $msg;
169 LOG llevError, $msg; 278 LOG llevWarn, $msg;
170 }; 279};
171} 280
281$Coro::State::DIEHOOK = sub {
282 return unless $^S eq 0; # "eq", not "=="
283
284 error Carp::longmess $_[0];
285
286 if (in_main) {#d#
287 error "DIEHOOK called in main context, Coro bug?\n";#d#
288 return;#d#
289 }#d#
290
291 # kill coroutine otherwise
292 Coro::terminate
293};
172 294
173@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 295@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
174@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 296@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
175@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 297@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
176@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 298@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
177@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 299@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
300@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
178@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 301@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
179 302
180# we bless all objects into (empty) derived classes to force a method lookup 303# we bless all objects into (empty) derived classes to force a method lookup
181# within the Safe compartment. 304# within the Safe compartment.
182for my $pkg (qw( 305for my $pkg (qw(
183 cf::global cf::attachable 306 cf::global cf::attachable
184 cf::object cf::object::player 307 cf::object cf::object::player
185 cf::client cf::player 308 cf::client cf::player
186 cf::arch cf::living 309 cf::arch cf::living
310 cf::map cf::mapspace
187 cf::map cf::party cf::region 311 cf::party cf::region
188)) { 312)) {
189 no strict 'refs';
190 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 313 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
191} 314}
192 315
193$Event::DIED = sub { 316$EV::DIED = sub {
194 warn "error in event callback: @_"; 317 Carp::cluck "error in event callback: @_";
195}; 318};
319
320#############################################################################
196 321
197=head2 UTILITY FUNCTIONS 322=head2 UTILITY FUNCTIONS
198 323
199=over 4 324=over 4
200 325
… …
219 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 344 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
220 $d 345 $d
221 } || "[unable to dump $_[0]: '$@']"; 346 } || "[unable to dump $_[0]: '$@']";
222} 347}
223 348
224use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
225
226=item $ref = cf::from_json $json 349=item $ref = cf::decode_json $json
227 350
228Converts a JSON string into the corresponding perl data structure. 351Converts a JSON string into the corresponding perl data structure.
229 352
230=item $json = cf::to_json $ref 353=item $json = cf::encode_json $ref
231 354
232Converts a perl data structure into its JSON representation. 355Converts a perl data structure into its JSON representation.
233 356
357=cut
358
359our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
360
361sub encode_json($) { $json_coder->encode ($_[0]) }
362sub decode_json($) { $json_coder->decode ($_[0]) }
363
364=item $ref = cf::yaml_load $scalar
365
366Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
367
368=cut
369
370sub fork_call(&@);
371
372sub yaml_load($) {
373 fork_call { YAML::XS::Load $_[0] } @_
374}
375
376=item cf::post_init { BLOCK }
377
378Execute the given codeblock, I<after> all extensions have been (re-)loaded,
379but I<before> the server starts ticking again.
380
381The codeblock will have a single boolean argument to indicate whether this
382is a reload or not.
383
384=cut
385
386sub post_init(&) {
387 push @POST_INIT, shift;
388}
389
390sub _post_init {
391 trace "running post_init jobs";
392
393 # run them in parallel...
394
395 my @join;
396
397 while () {
398 push @join, map &Coro::async ($_, 0), @POST_INIT;
399 @POST_INIT = ();
400
401 @join or last;
402
403 (pop @join)->join;
404 }
405}
406
234=item cf::lock_wait $string 407=item cf::lock_wait $string
235 408
236Wait until the given lock is available. See cf::lock_acquire. 409Wait until the given lock is available. See cf::lock_acquire.
237 410
238=item my $lock = cf::lock_acquire $string 411=item my $lock = cf::lock_acquire $string
239 412
240Wait until the given lock is available and then acquires it and returns 413Wait until the given lock is available and then acquires it and returns
241a Coro::guard object. If the guard object gets destroyed (goes out of scope, 414a L<Guard> object. If the guard object gets destroyed (goes out of scope,
242for example when the coroutine gets canceled), the lock is automatically 415for example when the coroutine gets canceled), the lock is automatically
243returned. 416returned.
244 417
418Locks are *not* recursive, locking from the same coro twice results in a
419deadlocked coro.
420
245Lock names should begin with a unique identifier (for example, cf::map::find 421Lock names should begin with a unique identifier (for example, cf::map::find
246uses map_find and cf::map::load uses map_load). 422uses map_find and cf::map::load uses map_load).
247 423
248=item $locked = cf::lock_active $string 424=item $locked = cf::lock_active $string
249 425
250Return true if the lock is currently active, i.e. somebody has locked it. 426Return true if the lock is currently active, i.e. somebody has locked it.
251 427
252=cut 428=cut
253 429
254our %LOCK; 430our $LOCKS = new Coro::SemaphoreSet;
255 431
256sub lock_wait($) { 432sub lock_wait($) {
257 my ($key) = @_; 433 $LOCKS->wait ($_[0]);
258
259 # wait for lock, if any
260 while ($LOCK{$key}) {
261 push @{ $LOCK{$key} }, $Coro::current;
262 Coro::schedule;
263 }
264} 434}
265 435
266sub lock_acquire($) { 436sub lock_acquire($) {
267 my ($key) = @_; 437 $LOCKS->guard ($_[0])
268
269 # wait, to be sure we are not locked
270 lock_wait $key;
271
272 $LOCK{$key} = [];
273
274 Coro::guard {
275 # wake up all waiters, to be on the safe side
276 $_->ready for @{ delete $LOCK{$key} };
277 }
278} 438}
279 439
280sub lock_active($) { 440sub lock_active($) {
281 my ($key) = @_; 441 $LOCKS->count ($_[0]) < 1
282
283 ! ! $LOCK{$key}
284} 442}
285 443
286sub freeze_mainloop { 444sub freeze_mainloop {
287 return unless $TICK_WATCHER->is_active; 445 tick_inhibit_inc;
288 446
289 my $guard = Coro::guard { 447 &Guard::guard (\&tick_inhibit_dec);
290 $TICK_WATCHER->start; 448}
449
450=item cf::periodic $interval, $cb
451
452Like EV::periodic, but randomly selects a starting point so that the actions
453get spread over time.
454
455=cut
456
457sub periodic($$) {
458 my ($interval, $cb) = @_;
459
460 my $start = rand List::Util::min 180, $interval;
461
462 EV::periodic $start, $interval, 0, $cb
463}
464
465=item cf::get_slot $time[, $priority[, $name]]
466
467Allocate $time seconds of blocking CPU time at priority C<$priority>:
468This call blocks and returns only when you have at least C<$time> seconds
469of cpu time till the next tick. The slot is only valid till the next cede.
470
471The optional C<$name> can be used to identify the job to run. It might be
472used for statistical purposes and should identify the same time-class.
473
474Useful for short background jobs.
475
476=cut
477
478our @SLOT_QUEUE;
479our $SLOT_QUEUE;
480our $SLOT_DECAY = 0.9;
481
482$SLOT_QUEUE->cancel if $SLOT_QUEUE;
483$SLOT_QUEUE = Coro::async {
484 $Coro::current->desc ("timeslot manager");
485
486 my $signal = new Coro::Signal;
487 my $busy;
488
489 while () {
490 next_job:
491
492 my $avail = cf::till_tick;
493
494 for (0 .. $#SLOT_QUEUE) {
495 if ($SLOT_QUEUE[$_][0] <= $avail) {
496 $busy = 0;
497 my $job = splice @SLOT_QUEUE, $_, 1, ();
498 $job->[2]->send;
499 Coro::cede;
500 goto next_job;
501 } else {
502 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
503 }
504 }
505
506 if (@SLOT_QUEUE) {
507 # we do not use wait_for_tick() as it returns immediately when tick is inactive
508 push @cf::WAIT_FOR_TICK, $signal;
509 $signal->wait;
510 } else {
511 $busy = 0;
512 Coro::schedule;
513 }
291 }; 514 }
292 $TICK_WATCHER->stop; 515};
293 $guard 516
517sub get_slot($;$$) {
518 return if tick_inhibit || $Coro::current == $Coro::main;
519
520 my ($time, $pri, $name) = @_;
521
522 $time = clamp $time, 0.01, $TICK * .6;
523
524 my $sig = new Coro::Signal;
525
526 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
527 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
528 $SLOT_QUEUE->ready;
529 $sig->wait;
294} 530}
295 531
296=item cf::async { BLOCK } 532=item cf::async { BLOCK }
297 533
298Currently the same as Coro::async_pool, meaning you cannot use 534Currently the same as Coro::async_pool, meaning you cannot use
… …
303 539
304BEGIN { *async = \&Coro::async_pool } 540BEGIN { *async = \&Coro::async_pool }
305 541
306=item cf::sync_job { BLOCK } 542=item cf::sync_job { BLOCK }
307 543
308The design of crossfire+ requires that the main coro ($Coro::main) is 544The design of Deliantra requires that the main coroutine ($Coro::main)
309always able to handle events or runnable, as crossfire+ is only partly 545is always able to handle events or runnable, as Deliantra is only
310reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 546partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
547acceptable.
311 548
312If it must be done, put the blocking parts into C<sync_job>. This will run 549If it must be done, put the blocking parts into C<sync_job>. This will run
313the given BLOCK in another coroutine while waiting for the result. The 550the given BLOCK in another coroutine while waiting for the result. The
314server will be frozen during this time, so the block should either finish 551server will be frozen during this time, so the block should either finish
315fast or be very important. 552fast or be very important.
… …
317=cut 554=cut
318 555
319sub sync_job(&) { 556sub sync_job(&) {
320 my ($job) = @_; 557 my ($job) = @_;
321 558
322 if ($Coro::current == $Coro::main) { 559 if (in_main) {
560 my $time = AE::time;
561
323 # this is the main coro, too bad, we have to block 562 # this is the main coro, too bad, we have to block
324 # till the operation succeeds, freezing the server :/ 563 # till the operation succeeds, freezing the server :/
325 564
326 # TODO: use suspend/resume instead 565 #LOG llevError, Carp::longmess "sync job";#d#
327 # (but this is cancel-safe) 566
328 my $freeze_guard = freeze_mainloop; 567 my $freeze_guard = freeze_mainloop;
329 568
330 my $busy = 1; 569 my $busy = 1;
331 my @res; 570 my @res;
332 571
333 (async { 572 (async {
573 $Coro::current->desc ("sync job coro");
334 @res = eval { $job->() }; 574 @res = eval { $job->() };
335 warn $@ if $@; 575 error $@ if $@;
336 undef $busy; 576 undef $busy;
337 })->prio (Coro::PRIO_MAX); 577 })->prio (Coro::PRIO_MAX);
338 578
339 while ($busy) { 579 while ($busy) {
340 Coro::cede or Event::one_event; 580 if (Coro::nready) {
581 Coro::cede_notself;
582 } else {
583 EV::loop EV::LOOP_ONESHOT;
341 } 584 }
585 }
586
587 my $time = AE::time - $time;
588
589 $TICK_START += $time; # do not account sync jobs to server load
342 590
343 wantarray ? @res : $res[0] 591 wantarray ? @res : $res[0]
344 } else { 592 } else {
345 # we are in another coroutine, how wonderful, everything just works 593 # we are in another coroutine, how wonderful, everything just works
346 594
… …
366 $EXT_CORO{$coro+0} = $coro; 614 $EXT_CORO{$coro+0} = $coro;
367 615
368 $coro 616 $coro
369} 617}
370 618
371sub write_runtime { 619=item fork_call { }, @args
372 my $guard = cf::lock_acquire "write_runtime";
373 620
374 my $runtime = "$LOCALDIR/runtime"; 621Executes the given code block with the given arguments in a seperate
622process, returning the results. Everything must be serialisable with
623Coro::Storable. May, of course, block. Note that the executed sub may
624never block itself or use any form of event handling.
375 625
376 warn "starting to write runtime...\n";#d# 626=cut
377 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
378 or return;
379 627
380 my $value = $cf::RUNTIME + 90 + 10; 628sub post_fork {
381 # 10 is the runtime save interval, for a monotonic clock 629 reset_signals;
382 # 60 allows for the watchdog to kill the server. 630}
383 631
384 (aio_write $fh, 0, (length $value), $value, 0) <= 0 632sub fork_call(&@) {
385 and return; 633 my ($cb, @args) = @_;
386 634
387 # always fsync - this file is important 635 # we seemingly have to make a local copy of the whole thing,
388 aio_fsync $fh 636 # otherwise perl prematurely frees the stuff :/
389 and return; 637 # TODO: investigate and fix (likely this will be rather laborious)
390 638
391 close $fh 639 my @res = Coro::Util::fork_eval {
392 or return; 640 cf::post_fork;
641 &$cb
642 } @args;
393 643
394 aio_rename "$runtime~", $runtime 644 wantarray ? @res : $res[-1]
395 and return; 645}
396 646
397 warn "... done writing runtime.\n";#d# 647sub objinfo {
398
399 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"
400} 812}
401 813
402=item cf::datalog type => key => value, ... 814=item cf::datalog type => key => value, ...
403 815
404Log 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.
405 817
406=cut 818=cut
407 819
408sub datalog($@) { 820sub datalog($@) {
409 my ($type, %kv) = @_; 821 my ($type, %kv) = @_;
410 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 822 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
411} 823}
412 824
413=back 825=back
414 826
415=cut 827=cut
416 828
417############################################################################# 829#############################################################################
418 830
419=head2 ATTACHABLE OBJECTS 831=head2 ATTACHABLE OBJECTS
420 832
421Many 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
422attach callbacks/event handlers (a collection of which is called an "attachment") 834attach callbacks/event handlers (a collection of which is called an "attachment")
423to it. All such attachable objects support the following methods. 835to it. All such attachable objects support the following methods.
424 836
425In 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>
426C<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
427crossfire+). 839Deliantra).
428 840
429=over 4 841=over 4
430 842
431=item $attachable->attach ($attachment, key => $value...) 843=item $attachable->attach ($attachment, key => $value...)
432 844
… …
476=item cf::CLASS::attachment $name, ... 888=item cf::CLASS::attachment $name, ...
477 889
478Register an attachment by C<$name> through which attachable objects of the 890Register an attachment by C<$name> through which attachable objects of the
479given CLASS can refer to this attachment. 891given CLASS can refer to this attachment.
480 892
481Some classes such as crossfire maps and objects can specify attachments 893Some classes such as deliantra maps and objects can specify attachments
482that 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.
483 895
484These calls expect any number of the following handler/hook descriptions: 896These calls expect any number of the following handler/hook descriptions:
485 897
486=over 4 898=over 4
… …
595 $registry = $CB_TYPE[$object_type] ||= []; 1007 $registry = $CB_TYPE[$object_type] ||= [];
596 1008
597 } elsif ($type eq "subtype") { 1009 } elsif ($type eq "subtype") {
598 defined $object_type or Carp::croak "subtype specified without type"; 1010 defined $object_type or Carp::croak "subtype specified without type";
599 my $object_subtype = shift @arg; 1011 my $object_subtype = shift @arg;
600 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 1012 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
601 1013
602 } elsif ($type eq "package") { 1014 } elsif ($type eq "package") {
603 my $pkg = shift @arg; 1015 my $pkg = shift @arg;
604 1016
605 while (my ($name, $id) = each %cb_id) { 1017 while (my ($name, $id) = each %cb_id) {
… …
610 1022
611 } elsif (exists $cb_id{$type}) { 1023 } elsif (exists $cb_id{$type}) {
612 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1024 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
613 1025
614 } elsif (ref $type) { 1026 } elsif (ref $type) {
615 warn "attaching objects not supported, ignoring.\n"; 1027 error "attaching objects not supported, ignoring.\n";
616 1028
617 } else { 1029 } else {
618 shift @arg; 1030 shift @arg;
619 warn "attach argument '$type' not supported, ignoring.\n"; 1031 error "attach argument '$type' not supported, ignoring.\n";
620 } 1032 }
621 } 1033 }
622} 1034}
623 1035
624sub _object_attach { 1036sub _object_attach {
… …
634 _attach $registry, $klass, @attach; 1046 _attach $registry, $klass, @attach;
635 } 1047 }
636 1048
637 $obj->{$name} = \%arg; 1049 $obj->{$name} = \%arg;
638 } else { 1050 } else {
639 warn "object uses attachment '$name' that is not available, postponing.\n"; 1051 info "object uses attachment '$name' which is not available, postponing.\n";
640 } 1052 }
641 1053
642 $obj->{_attachment}{$name} = undef; 1054 $obj->{_attachment}{$name} = undef;
643} 1055}
644 1056
… …
646 if (ref $_[0]) { 1058 if (ref $_[0]) {
647 _object_attach @_; 1059 _object_attach @_;
648 } else { 1060 } else {
649 _attach shift->_attach_registry, @_; 1061 _attach shift->_attach_registry, @_;
650 } 1062 }
1063 _recalc_want;
651}; 1064};
652 1065
653# all those should be optimised 1066# all those should be optimised
654sub cf::attachable::detach { 1067sub cf::attachable::detach {
655 my ($obj, $name) = @_; 1068 my ($obj, $name) = @_;
… …
658 delete $obj->{_attachment}{$name}; 1071 delete $obj->{_attachment}{$name};
659 reattach ($obj); 1072 reattach ($obj);
660 } else { 1073 } else {
661 Carp::croak "cannot, currently, detach class attachments"; 1074 Carp::croak "cannot, currently, detach class attachments";
662 } 1075 }
1076 _recalc_want;
663}; 1077};
664 1078
665sub cf::attachable::attached { 1079sub cf::attachable::attached {
666 my ($obj, $name) = @_; 1080 my ($obj, $name) = @_;
667 1081
… …
682 "; 1096 ";
683 die if $@; 1097 die if $@;
684} 1098}
685 1099
686our $override; 1100our $override;
687our @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?
688 1102
689sub override { 1103sub override {
690 $override = 1; 1104 $override = 1;
691 @invoke_results = (); 1105 @INVOKE_RESULTS = (@_);
692} 1106}
693 1107
694sub do_invoke { 1108sub do_invoke {
695 my $event = shift; 1109 my $event = shift;
696 my $callbacks = shift; 1110 my $callbacks = shift;
697 1111
698 @invoke_results = (); 1112 @INVOKE_RESULTS = ();
699 1113
700 local $override; 1114 local $override;
701 1115
702 for (@$callbacks) { 1116 for (@$callbacks) {
703 eval { &{$_->[1]} }; 1117 eval { &{$_->[1]} };
704 1118
705 if ($@) { 1119 if ($@) {
706 warn "$@";
707 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1120 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
708 override; 1121 override;
709 } 1122 }
710 1123
711 return 1 if $override; 1124 return 1 if $override;
712 } 1125 }
713 1126
714 0 1127 0
715} 1128}
716 1129
717=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1130=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
718 1131
719=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1132=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
720 1133
721Generate an object-specific event with the given arguments. 1134Generate an object-specific event with the given arguments.
722 1135
723This 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
724removed 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
725results (if you must, access C<@cf::invoke_results> directly). 1138results (if you must, access C<@cf::INVOKE_RESULTS> directly).
726 1139
727=back 1140=back
728 1141
729=cut 1142=cut
730 1143
731############################################################################# 1144#############################################################################
732# 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}
733 1188
734sub reattach { 1189sub reattach {
735 # basically do the same as instantiate, without calling instantiate 1190 # basically do the same as instantiate, without calling instantiate
736 my ($obj) = @_; 1191 my ($obj) = @_;
737 1192
1193 # no longer needed after getting rid of delete_package?
738 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
739 1195
740 my $registry = $obj->registry; 1196 my $registry = $obj->registry;
741 1197
742 @$registry = (); 1198 @$registry = ();
743 1199
… …
748 for (@$attach) { 1204 for (@$attach) {
749 my ($klass, @attach) = @$_; 1205 my ($klass, @attach) = @$_;
750 _attach $registry, $klass, @attach; 1206 _attach $registry, $klass, @attach;
751 } 1207 }
752 } else { 1208 } else {
753 warn "object uses attachment '$name' that is not available, postponing.\n"; 1209 info "object uses attachment '$name' that is not available, postponing.\n";
754 } 1210 }
755 } 1211 }
756} 1212}
757 1213
758cf::attachable->attach ( 1214cf::attachable->attach (
759 prio => -1000000, 1215 prio => -1000000,
760 on_instantiate => sub { 1216 on_instantiate => sub {
761 my ($obj, $data) = @_; 1217 my ($obj, $data) = @_;
762 1218
763 $data = from_json $data; 1219 $data = decode_json $data;
764 1220
765 for (@$data) { 1221 for (@$data) {
766 my ($name, $args) = @$_; 1222 my ($name, $args) = @$_;
767 1223
768 $obj->attach ($name, %{$args || {} }); 1224 $obj->attach ($name, %{$args || {} });
… …
784sub object_freezer_save { 1240sub object_freezer_save {
785 my ($filename, $rdata, $objs) = @_; 1241 my ($filename, $rdata, $objs) = @_;
786 1242
787 sync_job { 1243 sync_job {
788 if (length $$rdata) { 1244 if (length $$rdata) {
1245 utf8::decode (my $decname = $filename);
789 warn sprintf "saving %s (%d,%d)\n", 1246 trace sprintf "saving %s (%d,%d)\n",
790 $filename, length $$rdata, scalar @$objs; 1247 $decname, length $$rdata, scalar @$objs
1248 if $VERBOSE_IO;
791 1249
792 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1250 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
793 chmod SAVE_MODE, $fh; 1251 aio_chmod $fh, SAVE_MODE;
794 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1252 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
795 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 }
796 close $fh; 1257 aio_close $fh;
797 1258
798 if (@$objs) { 1259 if (@$objs) {
799 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) {
800 chmod SAVE_MODE, $fh; 1261 aio_chmod $fh, SAVE_MODE;
801 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1262 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
802 aio_write $fh, 0, (length $data), $data, 0; 1263 aio_write $fh, 0, (length $data), $data, 0;
803 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 }
804 close $fh; 1268 aio_close $fh;
805 aio_rename "$filename.pst~", "$filename.pst"; 1269 aio_rename "$filename.pst~", "$filename.pst";
806 } 1270 }
807 } else { 1271 } else {
808 aio_unlink "$filename.pst"; 1272 aio_unlink "$filename.pst";
809 } 1273 }
810 1274
811 aio_rename "$filename~", $filename; 1275 aio_rename "$filename~", $filename;
1276
1277 $filename =~ s%/[^/]+$%%;
1278 aio_pathsync $filename if $cf::USE_FSYNC;
812 } else { 1279 } else {
813 warn "FATAL: $filename~: $!\n"; 1280 error "unable to save objects: $filename~: $!\n";
814 } 1281 }
815 } else { 1282 } else {
816 aio_unlink $filename; 1283 aio_unlink $filename;
817 aio_unlink "$filename.pst"; 1284 aio_unlink "$filename.pst";
818 } 1285 }
819 } 1286 };
820} 1287}
821 1288
822sub object_freezer_as_string { 1289sub object_freezer_as_string {
823 my ($rdata, $objs) = @_; 1290 my ($rdata, $objs) = @_;
824 1291
… …
836 or return; 1303 or return;
837 1304
838 unless (aio_stat "$filename.pst") { 1305 unless (aio_stat "$filename.pst") {
839 (aio_load "$filename.pst", $av) >= 0 1306 (aio_load "$filename.pst", $av) >= 0
840 or return; 1307 or return;
1308
841 $av = eval { (Storable::thaw $av)->{objs} }; 1309 my $st = eval { Coro::Storable::thaw $av };
1310 $av = $st->{objs};
842 } 1311 }
843 1312
1313 utf8::decode (my $decname = $filename);
844 warn sprintf "loading %s (%d)\n", 1314 trace sprintf "loading %s (%d,%d)\n",
845 $filename, length $data, scalar @{$av || []};#d# 1315 $decname, length $data, scalar @{$av || []}
1316 if $VERBOSE_IO;
1317
846 return ($data, $av); 1318 ($data, $av)
847} 1319}
1320
1321=head2 COMMAND CALLBACKS
1322
1323=over 4
1324
1325=cut
848 1326
849############################################################################# 1327#############################################################################
850# command handling &c 1328# command handling &c
851 1329
852=item cf::register_command $name => \&callback($ob,$args); 1330=item cf::register_command $name => \&callback($ob,$args);
… …
865 push @{ $COMMAND{$name} }, [$caller, $cb]; 1343 push @{ $COMMAND{$name} }, [$caller, $cb];
866} 1344}
867 1345
868=item cf::register_extcmd $name => \&callback($pl,$packet); 1346=item cf::register_extcmd $name => \&callback($pl,$packet);
869 1347
870Register 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.
871 1353
872If 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
873called. 1355called.
874 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
875=cut 1368=cut
876 1369
877sub register_extcmd { 1370sub register_extcmd {
878 my ($name, $cb) = @_; 1371 my ($name, $cb) = @_;
879 1372
880 $EXTCMD{$name} = $cb; 1373 $EXTCMD{$name} = $cb;
881} 1374}
882 1375
1376sub register_exticmd {
1377 my ($name, $cb) = @_;
1378
1379 $EXTICMD{$name} = $cb;
1380}
1381
1382use File::Glob ();
1383
883cf::player->attach ( 1384cf::player->attach (
884 on_command => sub { 1385 on_unknown_command => sub {
885 my ($pl, $name, $params) = @_; 1386 my ($pl, $name, $params) = @_;
886 1387
887 my $cb = $COMMAND{$name} 1388 my $cb = $COMMAND{$name}
888 or return; 1389 or return;
889 1390
… …
894 cf::override; 1395 cf::override;
895 }, 1396 },
896 on_extcmd => sub { 1397 on_extcmd => sub {
897 my ($pl, $buf) = @_; 1398 my ($pl, $buf) = @_;
898 1399
899 my $msg = eval { from_json $buf }; 1400 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
900 1401
901 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
902 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1410 if (my $cb = $EXTCMD{$type}) {
903 if (my %reply = $cb->($pl, $msg)) { 1411 @reply = $cb->($pl, @payload);
904 $pl->ext_reply ($msg->{msgid}, %reply);
905 }
906 } 1412 }
1413
1414 $pl->ext_reply ($reply, @reply)
1415 if $reply;
1416
907 } else { 1417 } else {
908 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1418 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
909 } 1419 }
910 1420
911 cf::override; 1421 cf::override;
912 }, 1422 },
913); 1423);
914 1424
1425# "readahead" all extensions
915sub load_extension { 1426sub cache_extensions {
916 my ($path) = @_; 1427 my $grp = IO::AIO::aio_group;
917 1428
918 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1429 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
919 my $base = $1; 1430 for (grep /\.ext$/, @{$_[0]}) {
920 my $pkg = $1; 1431 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
921 $pkg =~ s/[^[:word:]]/_/g;
922 $pkg = "ext::$pkg";
923
924 warn "... loading '$path' into '$pkg'\n";
925
926 open my $fh, "<:utf8", $path
927 or die "$path: $!";
928
929 my $source =
930 "package $pkg; use strict; use utf8;\n"
931 . "#line 1 \"$path\"\n{\n"
932 . (do { local $/; <$fh> })
933 . "\n};\n1";
934
935 unless (eval $source) {
936 my $msg = $@ ? "$path: $@\n"
937 : "extension disabled.\n";
938 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
939 warn $@;
940 warn "mandatory extension failed to load, exiting.\n";
941 exit 1;
942 } 1432 }
943 die $@;
944 } 1433 };
945 1434
946 push @EXTS, $pkg; 1435 $grp
947} 1436}
948 1437
949sub load_extensions { 1438sub load_extensions {
1439 info "loading extensions...";
1440
1441 cf::sync_job {
1442 my %todo;
1443
950 for my $ext (<$LIBDIR/*.ext>) { 1444 for my $path (<$LIBDIR/*.ext>) {
951 next unless -r $ext; 1445 next unless -r $path;
952 eval { 1446
953 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 }
954 1 1510 }
955 } 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 }
956 } 1521 };
957} 1522}
958 1523
959############################################################################# 1524#############################################################################
960 1525
1526=back
1527
961=head2 CORE EXTENSIONS 1528=head2 CORE EXTENSIONS
962 1529
963Functions and methods that extend core crossfire objects. 1530Functions and methods that extend core deliantra objects.
964 1531
965=cut 1532=cut
966 1533
967package cf::player; 1534package cf::player;
968 1535
969use Coro::AIO; 1536use Coro::AIO;
970 1537
971=head3 cf::player 1538=head3 cf::player
972 1539
973=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}
974 1555
975=item cf::player::find $login 1556=item cf::player::find $login
976 1557
977Returns the given player object, loading it if necessary (might block). 1558Returns the given player object, loading it if necessary (might block).
978 1559
… …
997 1578
998sub exists($) { 1579sub exists($) {
999 my ($login) = @_; 1580 my ($login) = @_;
1000 1581
1001 $cf::PLAYER{$login} 1582 $cf::PLAYER{$login}
1002 or cf::sync_job { !aio_stat path $login } 1583 or !aio_stat path $login
1003} 1584}
1004 1585
1005sub find($) { 1586sub find($) {
1006 return $cf::PLAYER{$_[0]} || do { 1587 return $cf::PLAYER{$_[0]} || do {
1007 my $login = $_[0]; 1588 my $login = $_[0];
… …
1014 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1595 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1015 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1596 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1016 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1597 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1017 aio_unlink +(playerdir $login) . "/$login.pl"; 1598 aio_unlink +(playerdir $login) . "/$login.pl";
1018 1599
1019 my $pl = load_pl path $login 1600 my $f = new_from_file cf::object::thawer path $login
1020 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;
1021 $cf::PLAYER{$login} = $pl 1608 $cf::PLAYER{$login} = $pl
1022 } 1609 }
1023 } 1610 }
1024} 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);
1025 1625
1026sub save($) { 1626sub save($) {
1027 my ($pl) = @_; 1627 my ($pl) = @_;
1028 1628
1029 return if $pl->{deny_save}; 1629 return if $pl->{deny_save};
… …
1034 return if $pl->{deny_save}; 1634 return if $pl->{deny_save};
1035 1635
1036 aio_mkdir playerdir $pl, 0770; 1636 aio_mkdir playerdir $pl, 0770;
1037 $pl->{last_save} = $cf::RUNTIME; 1637 $pl->{last_save} = $cf::RUNTIME;
1038 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
1039 $pl->save_pl ($path); 1644 $pl->save_pl ($path);
1040 Coro::cede; 1645 cf::cede_to_tick;
1041} 1646}
1042 1647
1043sub new($) { 1648sub new($) {
1044 my ($login) = @_; 1649 my ($login) = @_;
1045 1650
… …
1051 $cf::PLAYER{$login} = $self; 1656 $cf::PLAYER{$login} = $self;
1052 1657
1053 $self 1658 $self
1054} 1659}
1055 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
1056=item $pl->quit_character 1671=item $pl->quit_character
1057 1672
1058Nukes the player without looking back. If logged in, the connection will 1673Nukes the player without looking back. If logged in, the connection will
1059be destroyed. May block for a long time. 1674be destroyed. May block for a long time.
1060 1675
… …
1064 my ($pl) = @_; 1679 my ($pl) = @_;
1065 1680
1066 my $name = $pl->ob->name; 1681 my $name = $pl->ob->name;
1067 1682
1068 $pl->{deny_save} = 1; 1683 $pl->{deny_save} = 1;
1069 $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
1070 1685
1071 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1686 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1072 $pl->deactivate; 1687 $pl->deactivate;
1688
1689 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1073 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1690 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1691 ext::highscore::check ($pl->ob);
1692
1074 $pl->ns->destroy if $pl->ns; 1693 $pl->ns->destroy if $pl->ns;
1075 1694
1076 my $path = playerdir $pl; 1695 my $path = playerdir $pl;
1077 my $temp = "$path~$cf::RUNTIME~deleting~"; 1696 my $temp = "$path~$cf::RUNTIME~deleting~";
1078 aio_rename $path, $temp; 1697 aio_rename $path, $temp;
… …
1113 or return []; 1732 or return [];
1114 1733
1115 my @logins; 1734 my @logins;
1116 1735
1117 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") {
1118 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1742 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1119 aio_read $fh, 0, 512, my $buf, 0 or next; 1743 aio_read $fh, 0, 512, my $buf, 0 or next;
1120 $buf !~ /^password -------------$/m or next; # official not-valid tag 1744 $buf !~ /^password -------------$/m or next; # official not-valid tag
1745 }
1121 1746
1122 utf8::decode $login; 1747 utf8::decode $login;
1123 push @logins, $login; 1748 push @logins, $login;
1124 } 1749 }
1125 1750
1126 \@logins 1751 \@logins
1127} 1752}
1128 1753
1129=item $player->maps 1754=item $player->maps
1755
1756=item cf::player::maps $login
1130 1757
1131Returns an arrayref of map paths that are private for this 1758Returns an arrayref of map paths that are private for this
1132player. May block. 1759player. May block.
1133 1760
1134=cut 1761=cut
… …
1152 } 1779 }
1153 1780
1154 \@paths 1781 \@paths
1155} 1782}
1156 1783
1784=item $protocol_xml = $player->expand_cfpod ($cfpod)
1785
1786Expand deliantra pod fragments into protocol xml.
1787
1157=item $player->ext_reply ($msgid, %msg) 1788=item $player->ext_reply ($msgid, @msg)
1158 1789
1159Sends an ext reply to the player. 1790Sends an ext reply to the player.
1160 1791
1161=cut 1792=cut
1162 1793
1163sub ext_reply($$%) { 1794sub ext_reply($$@) {
1164 my ($self, $id, %msg) = @_; 1795 my ($self, $id, @msg) = @_;
1165 1796
1166 $msg{msgid} = $id; 1797 $self->ns->ext_reply ($id, @msg)
1167
1168 $self->send ("ext " . cf::to_json \%msg);
1169} 1798}
1170 1799
1171=item $player->ext_event ($type, %msg) 1800=item $player->ext_msg ($type, @msg)
1172 1801
1173Sends an ext event to the client. 1802Sends an ext event to the client.
1174 1803
1175=cut 1804=cut
1176 1805
1177sub ext_event($$%) { 1806sub ext_msg($$@) {
1178 my ($self, $type, %msg) = @_; 1807 my ($self, $type, @msg) = @_;
1179 1808
1180 $self->ns->ext_event ($type, %msg); 1809 $self->ns->ext_msg ($type, @msg);
1181} 1810}
1182 1811
1183=head3 cf::region 1812=head3 cf::region
1184 1813
1185=over 4 1814=over 4
… …
1188 1817
1189package cf::region; 1818package cf::region;
1190 1819
1191=item cf::region::find_by_path $path 1820=item cf::region::find_by_path $path
1192 1821
1193Tries 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.
1194 1823
1195=cut 1824=cut
1196 1825
1197sub find_by_path($) { 1826sub find_by_path($) {
1198 my ($path) = @_; 1827 my ($path) = @_;
1199 1828
1829 $path =~ s/^~[^\/]*//; # skip ~login
1830
1200 my ($match, $specificity); 1831 my ($match, $specificity);
1201 1832
1202 for my $region (list) { 1833 for my $region (list) {
1203 if ($region->match && $path =~ $region->match) { 1834 if ($region->{match} && $path =~ $region->{match}) {
1204 ($match, $specificity) = ($region, $region->specificity) 1835 ($match, $specificity) = ($region, $region->specificity)
1205 if $region->specificity > $specificity; 1836 if $region->specificity > $specificity;
1206 } 1837 }
1207 } 1838 }
1208 1839
… …
1229our $MAX_RESET = 3600; 1860our $MAX_RESET = 3600;
1230our $DEFAULT_RESET = 3000; 1861our $DEFAULT_RESET = 3000;
1231 1862
1232sub generate_random_map { 1863sub generate_random_map {
1233 my ($self, $rmp) = @_; 1864 my ($self, $rmp) = @_;
1234 # mit "rum" bekleckern, nicht 1865
1866 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1867
1235 $self->_create_random_map ( 1868 $self->_create_random_map ($rmp);
1236 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1237 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1238 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1239 $rmp->{exit_on_final_map},
1240 $rmp->{xsize}, $rmp->{ysize},
1241 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1242 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1243 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1244 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1245 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1246 (cf::region::find $rmp->{region}), $rmp->{custom}
1247 )
1248} 1869}
1249 1870
1250=item cf::map->register ($regex, $prio) 1871=item cf::map->register ($regex, $prio)
1251 1872
1252Register 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
… …
1257 1878
1258sub register { 1879sub register {
1259 my (undef, $regex, $prio) = @_; 1880 my (undef, $regex, $prio) = @_;
1260 my $pkg = caller; 1881 my $pkg = caller;
1261 1882
1262 no strict;
1263 push @{"$pkg\::ISA"}, __PACKAGE__; 1883 push @{"$pkg\::ISA"}, __PACKAGE__;
1264 1884
1265 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1885 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1266} 1886}
1267 1887
1268# also paths starting with '/' 1888# also paths starting with '/'
1269$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1889$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1270 1890
1271sub thawer_merge { 1891sub thawer_merge {
1272 my ($self, $merge) = @_; 1892 my ($self, $merge) = @_;
1273 1893
1274 # we have to keep some variables in memory intact 1894 # we have to keep some variables in memory intact
1275 local $self->{path}; 1895 local $self->{path};
1276 local $self->{load_path}; 1896 local $self->{load_path};
1277 local $self->{deny_save};
1278 local $self->{deny_reset};
1279 1897
1280 $self->SUPER::thawer_merge ($merge); 1898 $self->SUPER::thawer_merge ($merge);
1281} 1899}
1282 1900
1283sub normalise { 1901sub normalise {
1284 my ($path, $base) = @_; 1902 my ($path, $base) = @_;
1285 1903
1286 $path = "$path"; # make sure its a string 1904 $path = "$path"; # make sure it's a string
1287 1905
1288 $path =~ s/\.map$//; 1906 $path =~ s/\.map$//;
1289 1907
1290 # map plan: 1908 # map plan:
1291 # 1909 #
… …
1306 $base =~ s{[^/]+/?$}{}; 1924 $base =~ s{[^/]+/?$}{};
1307 $path = "$base/$path"; 1925 $path = "$base/$path";
1308 } 1926 }
1309 1927
1310 for ($path) { 1928 for ($path) {
1311 redo if s{//}{/};
1312 redo if s{/\.?/}{/}; 1929 redo if s{/\.?/}{/};
1313 redo if s{/[^/]+/\.\./}{/}; 1930 redo if s{/[^/]+/\.\./}{/};
1314 } 1931 }
1315 1932
1316 $path 1933 $path
… …
1330 $self->init; # pass $1 etc. 1947 $self->init; # pass $1 etc.
1331 return $self; 1948 return $self;
1332 } 1949 }
1333 } 1950 }
1334 1951
1335 Carp::carp "unable to resolve path '$path' (base '$base')."; 1952 Carp::cluck "unable to resolve path '$path' (base '$base')";
1336 () 1953 ()
1337} 1954}
1338 1955
1339sub init { 1956sub init {
1340 my ($self) = @_; 1957 my ($self) = @_;
… …
1362 1979
1363# the temporary/swap location 1980# the temporary/swap location
1364sub save_path { 1981sub save_path {
1365 my ($self) = @_; 1982 my ($self) = @_;
1366 1983
1367 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1984 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1368 "$TMPDIR/$path.map" 1985 "$TMPDIR/$path.map"
1369} 1986}
1370 1987
1371# the unique path, undef == no special unique path 1988# the unique path, undef == no special unique path
1372sub uniq_path { 1989sub uniq_path {
1373 my ($self) = @_; 1990 my ($self) = @_;
1374 1991
1375 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1992 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1376 "$UNIQUEDIR/$path" 1993 "$UNIQUEDIR/$path"
1377} 1994}
1378 1995
1379# and all this just because we cannot iterate over 1996sub decay_objects {
1380# all maps in C++...
1381sub change_all_map_light {
1382 my ($change) = @_; 1997 my ($self) = @_;
1383 1998
1384 $_->change_map_light ($change) 1999 return if $self->{deny_reset};
1385 for grep $_->outdoor, values %cf::MAP; 2000
2001 $self->do_decay_objects;
1386} 2002}
1387 2003
1388sub unlink_save { 2004sub unlink_save {
1389 my ($self) = @_; 2005 my ($self) = @_;
1390 2006
… …
1395 2011
1396sub load_header_from($) { 2012sub load_header_from($) {
1397 my ($self, $path) = @_; 2013 my ($self, $path) = @_;
1398 2014
1399 utf8::encode $path; 2015 utf8::encode $path;
1400 #aio_open $path, O_RDONLY, 0 2016 my $f = new_from_file cf::object::thawer $path
1401 # or return;
1402
1403 $self->_load_header ($path)
1404 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;
1405 2024
1406 $self->{load_path} = $path; 2025 $self->{load_path} = $path;
1407 2026
1408 1 2027 1
1409} 2028}
… …
1448 $self->load_header_orig 2067 $self->load_header_orig
1449 or return; 2068 or return;
1450 $self->prepare_orig; 2069 $self->prepare_orig;
1451 } 2070 }
1452 2071
2072 $self->{deny_reset} = 1
2073 if $self->no_reset;
2074
1453 $self->default_region (cf::region::find_by_path $self->{path}) 2075 $self->default_region (cf::region::find_by_path $self->{path})
1454 unless $self->default_region; 2076 unless $self->default_region;
1455 2077
1456 1 2078 1
1457} 2079}
1458 2080
1459sub find; 2081sub find;
1460sub find { 2082sub find {
1461 my ($path, $origin) = @_; 2083 my ($path, $origin) = @_;
1462 2084
2085 cf::cede_to_tick;
2086
1463 $path = normalise $path, $origin && $origin->path; 2087 $path = normalise $path, $origin && $origin->path;
1464 2088
2089 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1465 cf::lock_wait "map_find:$path"; 2090 my $guard2 = cf::lock_acquire "map_find:$path";
1466 2091
1467 $cf::MAP{$path} || do { 2092 $cf::MAP{$path} || do {
1468 my $guard = cf::lock_acquire "map_find:$path";
1469 my $map = new_from_path cf::map $path 2093 my $map = new_from_path cf::map $path
1470 or return; 2094 or return;
1471 2095
1472 $map->{last_save} = $cf::RUNTIME; 2096 $map->{last_save} = $cf::RUNTIME;
1473 2097
1474 $map->load_header 2098 $map->load_header
1475 or return; 2099 or return;
1476 2100
1477 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 2101 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1478 # doing this can freeze the server in a sync job, obviously 2102 # doing this can freeze the server in a sync job, obviously
1479 #$cf::WAIT_FOR_TICK->wait; 2103 #$cf::WAIT_FOR_TICK->wait;
2104 undef $guard2;
2105 undef $guard1;
1480 $map->reset; 2106 $map->reset;
1481 undef $guard;
1482 return find $path; 2107 return find $path;
1483 } 2108 }
1484 2109
1485 $cf::MAP{$path} = $map 2110 $cf::MAP{$path} = $map
1486 } 2111 }
1487} 2112}
1488 2113
1489sub pre_load { } 2114sub pre_load { }
1490sub post_load { } 2115#sub post_load { } # XS
1491 2116
1492sub load { 2117sub load {
1493 my ($self) = @_; 2118 my ($self) = @_;
1494 2119
1495 local $self->{deny_reset} = 1; # loading can take a long time 2120 local $self->{deny_reset} = 1; # loading can take a long time
1496 2121
1497 my $path = $self->{path}; 2122 my $path = $self->{path};
1498 2123
1499 { 2124 {
1500 my $guard = cf::lock_acquire "map_load:$path"; 2125 my $guard = cf::lock_acquire "map_data:$path";
1501 2126
2127 return unless $self->valid;
1502 return if $self->in_memory != cf::MAP_SWAPPED; 2128 return unless $self->in_memory == cf::MAP_SWAPPED;
1503 2129
1504 $self->in_memory (cf::MAP_LOADING); 2130 $self->in_memory (cf::MAP_LOADING);
1505 2131
1506 $self->alloc; 2132 $self->alloc;
1507 2133
1508 $self->pre_load; 2134 $self->pre_load;
1509 Coro::cede; 2135 cf::cede_to_tick;
1510 2136
2137 my $f = new_from_file cf::object::thawer $self->{load_path};
2138 $f->skip_block;
1511 $self->_load_objects ($self->{load_path}, 1) 2139 $self->_load_objects ($f)
1512 or return; 2140 or return;
1513 2141
1514 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2142 $self->post_load_original
1515 if delete $self->{load_original}; 2143 if delete $self->{load_original};
1516 2144
1517 if (my $uniq = $self->uniq_path) { 2145 if (my $uniq = $self->uniq_path) {
1518 utf8::encode $uniq; 2146 utf8::encode $uniq;
1519 if (aio_open $uniq, O_RDONLY, 0) { 2147 unless (aio_stat $uniq) {
2148 if (my $f = new_from_file cf::object::thawer $uniq) {
1520 $self->clear_unique_items; 2149 $self->clear_unique_items;
1521 $self->_load_objects ($uniq, 0); 2150 $self->_load_objects ($f);
2151 $f->resolve_delayed_derefs;
2152 }
1522 } 2153 }
1523 } 2154 }
1524 2155
1525 Coro::cede; 2156 $f->resolve_delayed_derefs;
2157
2158 cf::cede_to_tick;
1526 # now do the right thing for maps 2159 # now do the right thing for maps
1527 $self->link_multipart_objects; 2160 $self->link_multipart_objects;
1528 $self->difficulty ($self->estimate_difficulty) 2161 $self->difficulty ($self->estimate_difficulty)
1529 unless $self->difficulty; 2162 unless $self->difficulty;
1530 Coro::cede; 2163 cf::cede_to_tick;
1531 2164
1532 unless ($self->{deny_activate}) { 2165 unless ($self->{deny_activate}) {
1533 $self->decay_objects; 2166 $self->decay_objects;
1534 $self->fix_auto_apply; 2167 $self->fix_auto_apply;
1535 $self->update_buttons; 2168 $self->update_buttons;
1536 Coro::cede; 2169 cf::cede_to_tick;
1537 $self->set_darkness_map;
1538 Coro::cede;
1539 $self->activate; 2170 $self->activate;
1540 } 2171 }
1541 2172
2173 $self->{last_save} = $cf::RUNTIME;
2174 $self->last_access ($cf::RUNTIME);
2175
1542 $self->in_memory (cf::MAP_IN_MEMORY); 2176 $self->in_memory (cf::MAP_ACTIVE);
1543 } 2177 }
1544 2178
1545 $self->post_load; 2179 $self->post_load;
1546}
1547 2180
2181 1
2182}
2183
2184# customize the map for a given player, i.e.
2185# return the _real_ map. used by e.g. per-player
2186# maps to change the path to ~playername/mappath
1548sub customise_for { 2187sub customise_for {
1549 my ($self, $ob) = @_; 2188 my ($self, $ob) = @_;
1550 2189
1551 return find "~" . $ob->name . "/" . $self->{path} 2190 return find "~" . $ob->name . "/" . $self->{path}
1552 if $self->per_player; 2191 if $self->per_player;
1553 2192
2193# return find "?party/" . $ob->name . "/" . $self->{path}
2194# if $self->per_party;
2195
1554 $self 2196 $self
1555} 2197}
1556 2198
1557# 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
1558sub load_diag { 2200sub load_neighbours {
1559 my ($map) = @_; 2201 my ($map) = @_;
1560 2202
1561 my @diag; # diagonal neighbours 2203 my @neigh; # diagonal neighbours
1562 2204
1563 for (0 .. 3) { 2205 for (0 .. 3) {
1564 my $neigh = $map->tile_path ($_) 2206 my $neigh = $map->tile_path ($_)
1565 or next; 2207 or next;
1566 $neigh = find $neigh, $map 2208 $neigh = find $neigh, $map
1567 or next; 2209 or next;
1568 $neigh->load; 2210 $neigh->load;
1569 2211
2212 # now find the diagonal neighbours
2213 push @neigh,
1570 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2214 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1571 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2215 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1572 } 2216 }
1573 2217
1574 for (@diag) { 2218 for (grep defined $_->[0], @neigh) {
2219 my ($path, $origin) = @$_;
1575 my $neigh = find @$_ 2220 my $neigh = find $path, $origin
1576 or next; 2221 or next;
1577 $neigh->load; 2222 $neigh->load;
1578 } 2223 }
1579} 2224}
1580 2225
1581sub find_sync { 2226sub find_sync {
1582 my ($path, $origin) = @_; 2227 my ($path, $origin) = @_;
1583 2228
1584 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
1585} 2233}
1586 2234
1587sub do_load_sync { 2235sub do_load_sync {
1588 my ($map) = @_; 2236 my ($map) = @_;
1589 2237
1590 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;
1591} 2242}
1592 2243
1593our %MAP_PREFETCH; 2244our %MAP_PREFETCH;
1594our $MAP_PREFETCHER = undef; 2245our $MAP_PREFETCHER = undef;
1595 2246
1596sub find_async { 2247sub find_async {
1597 my ($path, $origin) = @_; 2248 my ($path, $origin, $load) = @_;
1598 2249
1599 $path = normalise $path, $origin && $origin->{path}; 2250 $path = normalise $path, $origin && $origin->{path};
1600 2251
1601 if (my $map = $cf::MAP{$path}) { 2252 if (my $map = $cf::MAP{$path}) {
1602 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2253 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1603 } 2254 }
1604 2255
1605 undef $MAP_PREFETCH{$path}; 2256 $MAP_PREFETCH{$path} |= $load;
2257
1606 $MAP_PREFETCHER ||= cf::async { 2258 $MAP_PREFETCHER ||= cf::async {
2259 $Coro::current->{desc} = "map prefetcher";
2260
1607 while (%MAP_PREFETCH) { 2261 while (%MAP_PREFETCH) {
1608 for my $path (keys %MAP_PREFETCH) { 2262 while (my ($k, $v) = each %MAP_PREFETCH) {
1609 my $map = find $path 2263 if (my $map = find $k) {
1610 or next;
1611 $map->load; 2264 $map->load if $v;
2265 }
1612 2266
1613 delete $MAP_PREFETCH{$path}; 2267 delete $MAP_PREFETCH{$k};
1614 } 2268 }
1615 } 2269 }
1616 undef $MAP_PREFETCHER; 2270 undef $MAP_PREFETCHER;
1617 }; 2271 };
1618 $MAP_PREFETCHER->prio (6); 2272 $MAP_PREFETCHER->prio (6);
1619 2273
1620 () 2274 ()
1621} 2275}
1622 2276
2277# common code, used by both ->save and ->swapout
1623sub save { 2278sub _save {
1624 my ($self) = @_; 2279 my ($self) = @_;
1625
1626 my $lock = cf::lock_acquire "map_data:" . $self->path;
1627 2280
1628 $self->{last_save} = $cf::RUNTIME; 2281 $self->{last_save} = $cf::RUNTIME;
1629 2282
1630 return unless $self->dirty; 2283 return unless $self->dirty;
1631 2284
… …
1637 return if $self->{deny_save}; 2290 return if $self->{deny_save};
1638 2291
1639 local $self->{last_access} = $self->last_access;#d# 2292 local $self->{last_access} = $self->last_access;#d#
1640 2293
1641 cf::async { 2294 cf::async {
2295 $Coro::current->{desc} = "map player save";
1642 $_->contr->save for $self->players; 2296 $_->contr->save for $self->players;
1643 }; 2297 };
2298
2299 cf::get_slot 0.02;
1644 2300
1645 if ($uniq) { 2301 if ($uniq) {
1646 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2302 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1647 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2303 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1648 } else { 2304 } else {
1649 $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);
1650 } 2306 }
1651} 2307}
1652 2308
2309sub save {
2310 my ($self) = @_;
2311
2312 my $lock = cf::lock_acquire "map_data:$self->{path}";
2313
2314 $self->_save;
2315}
2316
1653sub swap_out { 2317sub swap_out {
1654 my ($self) = @_; 2318 my ($self) = @_;
1655 2319
1656 # save first because save cedes
1657 $self->save;
1658
1659 my $lock = cf::lock_acquire "map_data:" . $self->path; 2320 my $lock = cf::lock_acquire "map_data:$self->{path}";
1660 2321
2322 return if $self->in_memory != cf::MAP_ACTIVE;
2323 return if $self->{deny_save};
1661 return if $self->players; 2324 return if $self->players;
1662 return if $self->in_memory != cf::MAP_IN_MEMORY;
1663 return if $self->{deny_save};
1664 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
1665 $self->clear; 2335 $self->clear;
1666 $self->in_memory (cf::MAP_SWAPPED);
1667} 2336}
1668 2337
1669sub reset_at { 2338sub reset_at {
1670 my ($self) = @_; 2339 my ($self) = @_;
1671 2340
1672 # TODO: safety, remove and allow resettable per-player maps 2341 # TODO: safety, remove and allow resettable per-player maps
1673 return 1e99 if $self->isa ("ext::map_per_player");#d#
1674 return 1e99 if $self->{deny_reset}; 2342 return 1e99 if $self->{deny_reset};
1675 2343
1676 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2344 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1677 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;
1678 2346
… …
1689 my ($self) = @_; 2357 my ($self) = @_;
1690 2358
1691 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2359 my $lock = cf::lock_acquire "map_data:$self->{path}";
1692 2360
1693 return if $self->players; 2361 return if $self->players;
1694 return if $self->isa ("ext::map_per_player");#d#
1695 2362
1696 warn "resetting map ", $self->path;#d# 2363 cf::trace "resetting map ", $self->path, "\n";
1697 2364
1698 $self->in_memory (cf::MAP_SWAPPED); 2365 $self->in_memory (cf::MAP_SWAPPED);
1699 2366
1700 # need to save uniques path 2367 # need to save uniques path
1701 unless ($self->{deny_save}) { 2368 unless ($self->{deny_save}) {
… …
1705 if $uniq; 2372 if $uniq;
1706 } 2373 }
1707 2374
1708 delete $cf::MAP{$self->path}; 2375 delete $cf::MAP{$self->path};
1709 2376
2377 $self->deactivate;
2378 $_->clear_links_to ($self) for values %cf::MAP;
1710 $self->clear; 2379 $self->clear;
1711
1712 $_->clear_links_to ($self) for values %cf::MAP;
1713 2380
1714 $self->unlink_save; 2381 $self->unlink_save;
1715 $self->destroy; 2382 $self->destroy;
1716} 2383}
1717 2384
1718my $nuke_counter = "aaaa"; 2385my $nuke_counter = "aaaa";
1719 2386
1720sub nuke { 2387sub nuke {
1721 my ($self) = @_; 2388 my ($self) = @_;
1722 2389
2390 {
2391 my $lock = cf::lock_acquire "map_data:$self->{path}";
2392
1723 delete $cf::MAP{$self->path}; 2393 delete $cf::MAP{$self->path};
1724 2394
1725 $self->unlink_save; 2395 $self->unlink_save;
1726 2396
1727 bless $self, "cf::map"; 2397 bless $self, "cf::map::wrap";
1728 delete $self->{deny_reset}; 2398 delete $self->{deny_reset};
1729 $self->{deny_save} = 1; 2399 $self->{deny_save} = 1;
1730 $self->reset_timeout (1); 2400 $self->reset_timeout (1);
1731 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2401 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1732 2402
1733 $cf::MAP{$self->path} = $self; 2403 $cf::MAP{$self->path} = $self;
2404 }
1734 2405
1735 $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 ]
1736} 2443}
1737 2444
1738=item cf::map::unique_maps 2445=item cf::map::unique_maps
1739 2446
1740Returns an arrayref of paths of all shared maps that have 2447Returns an arrayref of paths of all shared maps that have
1741instantiated unique items. May block. 2448instantiated unique items. May block.
1742 2449
1743=cut 2450=cut
1744 2451
1745sub unique_maps() { 2452sub unique_maps() {
1746 my $files = aio_readdir $UNIQUEDIR 2453 [
1747 or return; 2454 map {
1748
1749 my @paths;
1750
1751 for (@$files) {
1752 utf8::decode $_; 2455 utf8::decode $_;
1753 next if /\.pst$/; 2456 s/\.map$//; # TODO future compatibility hack
1754 next unless /^$PATH_SEP/o; 2457 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1755 2458 ? ()
1756 push @paths, cf::map::normalise $_; 2459 : normalise $_
2460 } @{ aio_readdir $UNIQUEDIR or [] }
1757 } 2461 ]
1758
1759 \@paths
1760} 2462}
1761 2463
1762package 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}
1763 2495
1764=back 2496=back
1765 2497
1766=head3 cf::object 2498=head3 cf::object
1767 2499
… …
1771 2503
1772=over 4 2504=over 4
1773 2505
1774=item $ob->inv_recursive 2506=item $ob->inv_recursive
1775 2507
1776Returns 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.
1777 2510
1778=cut 2511=cut
1779 2512
1780sub inv_recursive_; 2513sub inv_recursive_;
1781sub inv_recursive_ { 2514sub inv_recursive_ {
… …
1784 2517
1785sub inv_recursive { 2518sub inv_recursive {
1786 inv_recursive_ inv $_[0] 2519 inv_recursive_ inv $_[0]
1787} 2520}
1788 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
1789package cf; 2550package cf;
1790 2551
1791=back 2552=back
1792 2553
1793=head3 cf::object::player 2554=head3 cf::object::player
… …
1799Sends 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>
1800can 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
1801dialogue with the given NPC character. 2562dialogue with the given NPC character.
1802 2563
1803=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};
1804 2579
1805# rough implementation of a future "reply" method that works 2580# rough implementation of a future "reply" method that works
1806# with dialog boxes. 2581# with dialog boxes.
1807#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
1808sub cf::object::player::reply($$$;$) { 2583sub cf::object::player::reply($$$;$) {
… …
1810 2585
1811 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2586 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1812 2587
1813 if ($self->{record_replies}) { 2588 if ($self->{record_replies}) {
1814 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2589 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2590
1815 } 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 {
1816 $msg = $npc->name . " says: $msg" if $npc; 2599 $msg = $npc->name . " says: $msg" if $npc;
1817 $self->message ($msg, $flags); 2600 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2601 }
1818 } 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 (@_);
1819} 2613}
1820 2614
1821=item $player_object->may ("access") 2615=item $player_object->may ("access")
1822 2616
1823Returns wether the given player is authorized to access resource "access" 2617Returns wether the given player is authorized to access resource "access"
… …
1836 2630
1837=item $player_object->enter_link 2631=item $player_object->enter_link
1838 2632
1839Freezes 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}>).
1840 2634
1841The 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.
1842I<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.
1843 2639
1844Will never block. 2640Will never block.
1845 2641
1846=item $player_object->leave_link ($map, $x, $y) 2642=item $player_object->leave_link ($map, $x, $y)
1847 2643
… …
1867sub cf::object::player::enter_link { 2663sub cf::object::player::enter_link {
1868 my ($self) = @_; 2664 my ($self) = @_;
1869 2665
1870 $self->deactivate_recursive; 2666 $self->deactivate_recursive;
1871 2667
2668 ++$self->{_link_recursion};
2669
1872 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2670 return if UNIVERSAL::isa $self->map, "ext::map_link";
1873 2671
1874 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2672 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1875 if $self->map; 2673 if $self->map && $self->map->{path} ne "{link}";
1876 2674
1877 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2675 $self->enter_map ($LINK_MAP || link_map, 3, 3);
1878} 2676}
1879 2677
1880sub cf::object::player::leave_link { 2678sub cf::object::player::leave_link {
1881 my ($self, $map, $x, $y) = @_; 2679 my ($self, $map, $x, $y) = @_;
2680
2681 return unless $self->contr->active;
1882 2682
1883 my $link_pos = delete $self->{_link_pos}; 2683 my $link_pos = delete $self->{_link_pos};
1884 2684
1885 unless ($map) { 2685 unless ($map) {
1886 # restore original map position 2686 # restore original map position
… …
1897 ($x, $y) = (-1, -1) 2697 ($x, $y) = (-1, -1)
1898 unless (defined $x) && (defined $y); 2698 unless (defined $x) && (defined $y);
1899 2699
1900 # use -1 or undef as default coordinates, not 0, 0 2700 # use -1 or undef as default coordinates, not 0, 0
1901 ($x, $y) = ($map->enter_x, $map->enter_y) 2701 ($x, $y) = ($map->enter_x, $map->enter_y)
1902 if $x <=0 && $y <= 0; 2702 if $x <= 0 && $y <= 0;
1903 2703
1904 $map->load; 2704 $map->load;
1905 $map->load_diag; 2705 $map->load_neighbours;
1906 2706
1907 return unless $self->contr->active; 2707 return unless $self->contr->active;
1908 $self->activate_recursive;
1909 2708
1910 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2709 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1911 $self->enter_map ($map, $x, $y); 2710 if ($self->enter_map ($map, $x, $y)) {
1912} 2711 # entering was successful
1913 2712 delete $self->{_link_recursion};
1914cf::player->attach ( 2713 # only activate afterwards, to support waiting in hooks
1915 on_logout => sub { 2714 $self->activate_recursive;
1916 my ($pl) = @_;
1917
1918 # abort map switching before logout
1919 if ($pl->ob->{_link_pos}) {
1920 cf::sync_job {
1921 $pl->ob->leave_link
1922 };
1923 }
1924 }, 2715 }
1925 on_login => sub {
1926 my ($pl) = @_;
1927 2716
1928 # try to abort aborted map switching on player login :) 2717}
1929 # should happen only on crashes
1930 if ($pl->ob->{_link_pos}) {
1931 $pl->ob->enter_link;
1932 (async {
1933 $pl->ob->reply (undef,
1934 "There was an internal problem at your last logout, "
1935 . "the server will try to bring you to your intended destination in a second.",
1936 cf::NDI_RED);
1937 # we need this sleep as the login has a concurrent enter_exit running
1938 # and this sleep increases chances of the player not ending up in scorn
1939 Coro::Timer::sleep 1;
1940 $pl->ob->leave_link;
1941 })->prio (2);
1942 }
1943 },
1944);
1945 2718
1946=item $player_object->goto ($path, $x, $y) 2719=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
1947 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
1948=cut 2730=cut
2731
2732our $GOTOGEN;
1949 2733
1950sub cf::object::player::goto { 2734sub cf::object::player::goto {
1951 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;
1952 2745
1953 $self->enter_link; 2746 $self->enter_link;
1954 2747
1955 (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
1956 my $map = eval { 2770 my $map = eval {
1957 my $map = cf::map::find $path; 2771 my $map = defined $path ? cf::map::find $path : undef;
2772
2773 if ($map) {
1958 $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
1959 $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 $@;
1960 } or 2786 }
1961 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1962 2787
2788 if ($gen == $self->{_goto_generation}) {
2789 delete $self->{_goto_generation};
1963 $self->leave_link ($map, $x, $y); 2790 $self->leave_link ($map, $x, $y);
2791 }
2792
2793 $done->($self) if $done;
1964 })->prio (1); 2794 })->prio (1);
1965} 2795}
1966 2796
1967=item $player_object->enter_exit ($exit_object) 2797=item $player_object->enter_exit ($exit_object)
1968 2798
… …
1988} 2818}
1989 2819
1990sub prepare_random_map { 2820sub prepare_random_map {
1991 my ($exit) = @_; 2821 my ($exit) = @_;
1992 2822
1993 my $guard = cf::lock_acquire "exit_prepare:$exit";
1994
1995 # all this does is basically replace the /! path by 2823 # all this does is basically replace the /! path by
1996 # a new random map path (?random/...) with a seed 2824 # a new random map path (?random/...) with a seed
1997 # that depends on the exit object 2825 # that depends on the exit object
1998 2826
1999 my $rmp = parse_random_map_params $exit->msg; 2827 my $rmp = parse_random_map_params $exit->msg;
… …
2001 if ($exit->map) { 2829 if ($exit->map) {
2002 $rmp->{region} = $exit->region->name; 2830 $rmp->{region} = $exit->region->name;
2003 $rmp->{origin_map} = $exit->map->path; 2831 $rmp->{origin_map} = $exit->map->path;
2004 $rmp->{origin_x} = $exit->x; 2832 $rmp->{origin_x} = $exit->x;
2005 $rmp->{origin_y} = $exit->y; 2833 $rmp->{origin_y} = $exit->y;
2834
2835 $exit->map->touch;
2006 } 2836 }
2007 2837
2008 $rmp->{random_seed} ||= $exit->random_seed; 2838 $rmp->{random_seed} ||= $exit->random_seed;
2009 2839
2010 my $data = cf::to_json $rmp; 2840 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2011 my $md5 = Digest::MD5::md5_hex $data; 2841 my $md5 = Digest::MD5::md5_hex $data;
2012 my $meta = "$RANDOMDIR/$md5.meta"; 2842 my $meta = "$RANDOMDIR/$md5.meta";
2013 2843
2014 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2844 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2015 aio_write $fh, 0, (length $data), $data, 0; 2845 aio_write $fh, 0, (length $data), $data, 0;
2016 undef $fh; 2846 undef $fh;
2017 aio_rename "$meta~", $meta; 2847 aio_rename "$meta~", $meta;
2018 2848
2849 my $slaying = "?random/$md5";
2850
2851 if ($exit->valid) {
2019 $exit->slaying ("?random/$md5"); 2852 $exit->slaying ("?random/$md5");
2020 $exit->msg (undef); 2853 $exit->msg (undef);
2854 }
2021 } 2855 }
2022} 2856}
2023 2857
2024sub cf::object::player::enter_exit { 2858sub cf::object::player::enter_exit {
2025 my ($self, $exit) = @_; 2859 my ($self, $exit) = @_;
2026 2860
2027 return unless $self->type == cf::PLAYER; 2861 return unless $self->type == cf::PLAYER;
2028 2862
2029 if ($exit->slaying eq "/!") {
2030 #TODO: this should de-fi-ni-te-ly not be a sync-job
2031 # the problem is that $exit might not survive long enough
2032 # so it needs to be done right now, right here
2033 cf::sync_job { prepare_random_map $exit };
2034 }
2035
2036 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2037 my $hp = $exit->stats->hp;
2038 my $sp = $exit->stats->sp;
2039
2040 $self->enter_link; 2863 $self->enter_link;
2041 2864
2042 (async { 2865 (async {
2043 $self->deactivate_recursive; # just to be sure 2866 $Coro::current->{desc} = "enter_exit";
2867
2044 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
2045 $self->goto ($slaying, $hp, $sp); 2883 $self->goto ($map, $x, $y);
2046 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
2047 1; 2889 1
2048 }) { 2890 }) {
2049 $self->message ("Something went wrong deep within the crossfire server. " 2891 $self->message ("Something went wrong deep within the deliantra server. "
2050 . "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. "
2051 . "Please report this to the dungeon master!", 2893 . "Please report this to the dungeon master!",
2052 cf::NDI_UNIQUE | cf::NDI_RED); 2894 cf::NDI_UNIQUE | cf::NDI_RED);
2053 2895
2054 warn "ERROR in enter_exit: $@"; 2896 error "ERROR in enter_exit: $@";
2055 $self->leave_link; 2897 $self->leave_link;
2056 } 2898 }
2057 })->prio (1); 2899 })->prio (1);
2058} 2900}
2059 2901
… …
2073 2915
2074 utf8::encode $text; 2916 utf8::encode $text;
2075 $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);
2076} 2918}
2077 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
2078=item $client->ext_event ($type, %msg) 3107=item $client->ext_msg ($type, @msg)
2079 3108
2080Sends an exti event to the client. 3109Sends an ext event to the client.
2081 3110
2082=cut 3111=cut
2083 3112
2084sub cf::client::ext_event($$%) { 3113sub cf::client::ext_msg($$@) {
2085 my ($self, $type, %msg) = @_; 3114 my ($self, $type, @msg) = @_;
2086 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
2087 $msg{msgtype} = "event_$type"; 3119 push @msg, msgtype => "event_$type";
2088 $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 }
2089} 3140}
2090 3141
2091=item $success = $client->query ($flags, "text", \&cb) 3142=item $success = $client->query ($flags, "text", \&cb)
2092 3143
2093Queues a query to the client, calling the given callback with 3144Queues a query to the client, calling the given callback with
2094the 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>,
2095C<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>.
2096 3147
2097Queries 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
2098reliable at some point in the future. 3149become reliable at some point in the future.
2099 3150
2100=cut 3151=cut
2101 3152
2102sub cf::client::query { 3153sub cf::client::query {
2103 my ($self, $flags, $text, $cb) = @_; 3154 my ($self, $flags, $text, $cb) = @_;
… …
2111 utf8::encode $text; 3162 utf8::encode $text;
2112 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 3163 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2113 3164
2114 $self->send_packet ($self->{query_queue}[0][0]) 3165 $self->send_packet ($self->{query_queue}[0][0])
2115 if @{ $self->{query_queue} } == 1; 3166 if @{ $self->{query_queue} } == 1;
3167
3168 1
2116} 3169}
2117 3170
2118cf::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 },
2119 on_reply => sub { 3177 on_reply => sub {
2120 my ($ns, $msg) = @_; 3178 my ($ns, $msg) = @_;
2121 3179
2122 # this weird shuffling is so that direct followup queries 3180 # this weird shuffling is so that direct followup queries
2123 # get handled first 3181 # get handled first
… …
2135 } else { 3193 } else {
2136 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3194 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2137 } 3195 }
2138 } 3196 }
2139 }, 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 },
2140); 3224);
2141 3225
2142=item $client->async (\&cb) 3226=item $client->async (\&cb)
2143 3227
2144Create a new coroutine, running the specified callback. The coroutine will 3228Create a new coroutine, running the specified callback. The coroutine will
… …
2160 3244
2161 $coro 3245 $coro
2162} 3246}
2163 3247
2164cf::client->attach ( 3248cf::client->attach (
2165 on_destroy => sub { 3249 on_client_destroy => sub {
2166 my ($ns) = @_; 3250 my ($ns) = @_;
2167 3251
2168 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3252 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2169 }, 3253 },
2170); 3254);
… …
2185our $safe = new Safe "safe"; 3269our $safe = new Safe "safe";
2186our $safe_hole = new Safe::Hole; 3270our $safe_hole = new Safe::Hole;
2187 3271
2188$SIG{FPE} = 'IGNORE'; 3272$SIG{FPE} = 'IGNORE';
2189 3273
2190$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));
2191 3279
2192# here we export the classes and methods available to script code 3280# here we export the classes and methods available to script code
2193 3281
2194=pod 3282=pod
2195 3283
2196The following functions and methods are available within a safe environment: 3284The following functions and methods are available within a safe environment:
2197 3285
2198 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
2199 cf::object::player player 3291 cf::object::player
2200 cf::player peaceful 3292 player
2201 cf::map trigger 3293
3294 cf::player
3295 peaceful
3296
3297 cf::map
3298 trigger
2202 3299
2203=cut 3300=cut
2204 3301
2205for ( 3302for (
2206 ["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)],
2207 ["cf::object::player" => qw(player)], 3306 ["cf::object::player" => qw(player)],
2208 ["cf::player" => qw(peaceful)], 3307 ["cf::player" => qw(peaceful send_msg)],
2209 ["cf::map" => qw(trigger)], 3308 ["cf::map" => qw(trigger)],
2210) { 3309) {
2211 no strict 'refs';
2212 my ($pkg, @funs) = @$_; 3310 my ($pkg, @funs) = @$_;
2213 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3311 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2214 for @funs; 3312 for @funs;
2215} 3313}
2216 3314
… …
2231 3329
2232 my $qcode = $code; 3330 my $qcode = $code;
2233 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3331 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2234 $qcode =~ s/\n/\\n/g; 3332 $qcode =~ s/\n/\\n/g;
2235 3333
3334 %vars = (_dummy => 0) unless %vars;
3335
3336 my @res;
2236 local $_; 3337 local $_;
2237 local @safe::cf::_safe_eval_args = values %vars;
2238 3338
2239 my $eval = 3339 my $eval =
2240 "do {\n" 3340 "do {\n"
2241 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3341 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2242 . "#line 0 \"{$qcode}\"\n" 3342 . "#line 0 \"{$qcode}\"\n"
2243 . $code 3343 . $code
2244 . "\n}" 3344 . "\n}"
2245 ; 3345 ;
2246 3346
3347 if ($CFG{safe_eval}) {
2247 sub_generation_inc; 3348 sub_generation_inc;
3349 local @safe::cf::_safe_eval_args = values %vars;
2248 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3350 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2249 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 }
2250 3356
2251 if ($@) { 3357 if ($@) {
2252 warn "$@"; 3358 warn "$@",
2253 warn "while executing safe code '$code'\n"; 3359 "while executing safe code '$code'\n",
2254 warn "with arguments " . (join " ", %vars) . "\n"; 3360 "with arguments " . (join " ", %vars) . "\n";
2255 } 3361 }
2256 3362
2257 wantarray ? @res : $res[0] 3363 wantarray ? @res : $res[0]
2258} 3364}
2259 3365
… …
2273=cut 3379=cut
2274 3380
2275sub register_script_function { 3381sub register_script_function {
2276 my ($fun, $cb) = @_; 3382 my ($fun, $cb) = @_;
2277 3383
2278 no strict 'refs'; 3384 $fun = "safe::$fun" if $CFG{safe_eval};
2279 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3385 *$fun = $safe_hole->wrap ($cb);
2280} 3386}
2281 3387
2282=back 3388=back
2283 3389
2284=cut 3390=cut
2285
2286#############################################################################
2287
2288=head2 EXTENSION DATABASE SUPPORT
2289
2290Crossfire maintains a very simple database for extension use. It can
2291currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2292convert to/from binary).
2293
2294The parameter C<$family> should best start with the name of the extension
2295using it, it should be unique.
2296
2297=over 4
2298
2299=item $value = cf::db_get $family => $key
2300
2301Returns a single value from the database.
2302
2303=item cf::db_put $family => $key => $value
2304
2305Stores the given C<$value> in the family.
2306
2307=cut
2308
2309our $DB;
2310
2311sub db_init {
2312 unless ($DB) {
2313 $DB = BDB::db_create $DB_ENV;
2314
2315 cf::sync_job {
2316 eval {
2317 $DB->set_flags (BDB::CHKSUM);
2318
2319 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2320 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2321 cf::cleanup "db_open(db): $!" if $!;
2322 };
2323 cf::cleanup "db_open(db): $@" if $@;
2324 };
2325 }
2326}
2327
2328sub db_get($$) {
2329 my $key = "$_[0]/$_[1]";
2330
2331 cf::sync_job {
2332 BDB::db_get $DB, undef, $key, my $data;
2333
2334 $! ? ()
2335 : $data
2336 }
2337}
2338
2339sub db_put($$$) {
2340 BDB::dbreq_pri 4;
2341 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2342}
2343
2344=item cf::cache $id => [$paths...], $processversion => $process
2345
2346Generic caching function that returns the value of the resource $id,
2347caching and regenerating as required.
2348
2349This function can block.
2350
2351=cut
2352
2353sub cache {
2354 my ($id, $src, $processversion, $process) = @_;
2355
2356 my $meta =
2357 join "\x00",
2358 $processversion,
2359 map {
2360 aio_stat $_
2361 and Carp::croak "$_: $!";
2362
2363 ($_, (stat _)[7,9])
2364 } @$src;
2365
2366 my $dbmeta = db_get cache => "$id/meta";
2367 if ($dbmeta ne $meta) {
2368 # changed, we may need to process
2369
2370 my @data;
2371 my $md5;
2372
2373 for (0 .. $#$src) {
2374 0 <= aio_load $src->[$_], $data[$_]
2375 or Carp::croak "$src->[$_]: $!";
2376 }
2377
2378 # if processing is expensive, check
2379 # checksum first
2380 if (1) {
2381 $md5 =
2382 join "\x00",
2383 $processversion,
2384 map {
2385 Coro::cede;
2386 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2387 } 0.. $#$src;
2388
2389
2390 my $dbmd5 = db_get cache => "$id/md5";
2391 if ($dbmd5 eq $md5) {
2392 db_put cache => "$id/meta", $meta;
2393
2394 return db_get cache => "$id/data";
2395 }
2396 }
2397
2398 my $t1 = Time::HiRes::time;
2399 my $data = $process->(\@data);
2400 my $t2 = Time::HiRes::time;
2401
2402 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2403
2404 db_put cache => "$id/data", $data;
2405 db_put cache => "$id/md5" , $md5;
2406 db_put cache => "$id/meta", $meta;
2407
2408 return $data;
2409 }
2410
2411 db_get cache => "$id/data"
2412}
2413
2414=item fork_call { }, $args
2415
2416Executes the given code block with the given arguments in a seperate
2417process, returning the results. Everything must be serialisable with
2418Coro::Storable. May, of course, block. Note that the executed sub may
2419never block itself or use any form of Event handling.
2420
2421=cut
2422
2423sub fork_call(&@) {
2424 my ($cb, @args) = @_;
2425
2426# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2427# or die "socketpair: $!";
2428 pipe my $fh1, my $fh2
2429 or die "pipe: $!";
2430
2431 if (my $pid = fork) {
2432 close $fh2;
2433
2434 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2435 $res = Coro::Storable::thaw $res;
2436
2437 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2438
2439 die $$res unless "ARRAY" eq ref $res;
2440
2441 return wantarray ? @$res : $res->[-1];
2442 } else {
2443 reset_signals;
2444 local $SIG{__WARN__};
2445 local $SIG{__DIE__};
2446 eval {
2447 close $fh1;
2448
2449 my @res = eval { $cb->(@args) };
2450 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2451 };
2452
2453 warn $@ if $@;
2454 _exit 0;
2455 }
2456}
2457
2458
2459 3391
2460############################################################################# 3392#############################################################################
2461# the server's init and main functions 3393# the server's init and main functions
2462 3394
2463sub load_facedata($) { 3395sub load_facedata($) {
2464 my ($path) = @_; 3396 my ($path) = @_;
2465 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
2466 warn "loading facedata from $path\n"; 3404 trace "loading facedata from $path\n";
2467 3405
2468 my $facedata;
2469 0 < aio_load $path, $facedata 3406 0 < aio_load $path, my $facedata
2470 or die "$path: $!"; 3407 or die "$path: $!";
2471 3408
2472 $facedata = Coro::Storable::thaw $facedata; 3409 $facedata = Coro::Storable::thaw $facedata;
2473 3410
2474 $facedata->{version} == 2 3411 $facedata->{version} == 2
2475 or cf::cleanup "$path: version mismatch, cannot proceed."; 3412 or cf::cleanup "$path: version mismatch, cannot proceed.";
2476 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
2477 { 3423 {
2478 my $faces = $facedata->{faceinfo}; 3424 my $faces = $facedata->{faceinfo};
2479 3425
2480 while (my ($face, $info) = each %$faces) { 3426 while (my ($face, $info) = each %$faces) {
2481 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3427 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3428
2482 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3429 cf::face::set_visibility $idx, $info->{visibility};
3430 cf::face::set_magicmap $idx, $info->{magicmap};
2483 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3431 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2484 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3432 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2485 Coro::cede; 3433 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3434
3435 cf::cede_to_tick;
2486 } 3436 }
2487 3437
2488 while (my ($face, $info) = each %$faces) { 3438 while (my ($face, $info) = each %$faces) {
2489 next unless $info->{smooth}; 3439 next unless $info->{smooth};
3440
2490 my $idx = cf::face::find $face 3441 my $idx = cf::face::find $face
2491 or next; 3442 or next;
3443
2492 if (my $smooth = cf::face::find $info->{smooth}) { 3444 if (my $smooth = cf::face::find $info->{smooth}) {
3445 cf::face::set_smooth $idx, $smooth;
2493 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3446 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2494 } else { 3447 } else {
2495 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3448 error "smooth face '$info->{smooth}' not found for face '$face'";
2496 } 3449 }
2497 Coro::cede; 3450
3451 cf::cede_to_tick;
2498 } 3452 }
2499 } 3453 }
2500 3454
2501 { 3455 {
2502 my $anims = $facedata->{animinfo}; 3456 my $anims = $facedata->{animinfo};
2503 3457
2504 while (my ($anim, $info) = each %$anims) { 3458 while (my ($anim, $info) = each %$anims) {
2505 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3459 cf::anim::set $anim, $info->{frames}, $info->{facings};
2506 Coro::cede; 3460 cf::cede_to_tick;
2507 } 3461 }
2508 3462
2509 cf::anim::invalidate_all; # d'oh 3463 cf::anim::invalidate_all; # d'oh
2510 } 3464 }
2511 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
2512 1 3485 1
2513} 3486}
2514 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
2515sub 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
2516 load_resource_file "$MAPDIR/regions" 3511 load_resource_file "$MAPDIR/regions"
2517 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 }
2518} 3518}
2519 3519
2520sub reload_facedata { 3520sub reload_facedata {
2521 load_facedata "$DATADIR/facedata" 3521 load_facedata "$DATADIR/facedata"
2522 or die "unable to load facedata\n"; 3522 or die "unable to load facedata\n";
… …
2530sub reload_treasures { 3530sub reload_treasures {
2531 load_resource_file "$DATADIR/treasures" 3531 load_resource_file "$DATADIR/treasures"
2532 or die "unable to load treasurelists\n"; 3532 or die "unable to load treasurelists\n";
2533} 3533}
2534 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
2535sub reload_resources { 3558sub reload_resources {
2536 warn "reloading resource files...\n"; 3559 trace "reloading resource files...\n";
2537 3560
3561 reload_exp_table;
3562 reload_materials;
3563 reload_facedata;
3564 reload_sound;
3565 reload_archetypes;
2538 reload_regions; 3566 reload_regions;
2539 reload_facedata;
2540 reload_archetypes;
2541 reload_treasures; 3567 reload_treasures;
2542 3568
2543 warn "finished reloading resource files\n"; 3569 trace "finished reloading resource files\n";
2544} 3570}
2545 3571
2546sub init { 3572sub reload_config {
2547 reload_resources; 3573 trace "reloading config file...\n";
2548}
2549 3574
2550sub cfg_load { 3575 0 < aio_load "$CONFDIR/config", my $config
2551 open my $fh, "<:utf8", "$CONFDIR/config" 3576 or die "$CONFDIR/config: $!";
2552 or return;
2553 3577
2554 local $/; 3578 utf8::decode $config;
2555 *CFG = YAML::Syck::Load <$fh>; 3579 *CFG = yaml_load $config;
2556 3580
2557 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3581 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
2558 3582
2559 $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};
2560 $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};
2561 3585
2562 if (exists $CFG{mlockall}) { 3586 if (exists $CFG{mlockall}) {
… …
2566 }; 3590 };
2567 warn $@ if $@; 3591 warn $@ if $@;
2568 } 3592 }
2569} 3593}
2570 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
2571sub 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
2572 # we must not ever block the main coroutine 3633 # we must not ever block the main coroutine
2573 local $Coro::idle = sub { 3634 local $Coro::idle = sub {
2574 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#
2575 (async { 3636 (async {
2576 Event::one_event; 3637 $Coro::current->{desc} = "IDLE BUG HANDLER";
3638 EV::loop EV::LOOP_ONESHOT;
2577 })->prio (Coro::PRIO_MAX); 3639 })->prio (Coro::PRIO_MAX);
2578 }; 3640 };
2579 3641
2580 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;
2581 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
2582 load_extensions; 3665 load_extensions;
2583 3666
2584 $TICK_WATCHER->start; 3667 utime time, time, $RUNTIMEFILE;
2585 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;
2586} 3685}
2587 3686
2588############################################################################# 3687#############################################################################
2589# initialisation and cleanup 3688# initialisation and cleanup
2590 3689
2591# install some emergency cleanup handlers 3690# install some emergency cleanup handlers
2592BEGIN { 3691BEGIN {
3692 our %SIGWATCHER = ();
2593 for my $signal (qw(INT HUP TERM)) { 3693 for my $signal (qw(INT HUP TERM)) {
2594 Event->signal ( 3694 $SIGWATCHER{$signal} = AE::signal $signal, sub {
2595 reentrant => 0,
2596 data => WF_AUTOCANCEL,
2597 signal => $signal,
2598 prio => 0,
2599 cb => sub {
2600 cf::cleanup "SIG$signal"; 3695 cf::cleanup "SIG$signal";
2601 },
2602 ); 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
2603 } 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 };
2604} 3786}
2605 3787
2606sub emergency_save() { 3788sub emergency_save() {
2607 my $freeze_guard = cf::freeze_mainloop; 3789 my $freeze_guard = cf::freeze_mainloop;
2608 3790
2609 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;
2610 3797
2611 cf::sync_job { 3798 cf::sync_job {
3799 cf::write_runtime_sync; # external watchdog should not bark
3800
2612 # use a peculiar iteration method to avoid tripping on perl 3801 # use a peculiar iteration method to avoid tripping on perl
2613 # refcount bugs in for. also avoids problems with players 3802 # refcount bugs in for. also avoids problems with players
2614 # and maps saved/destroyed asynchronously. 3803 # and maps saved/destroyed asynchronously.
2615 warn "begin emergency player save\n"; 3804 info "emergency_perl_save: begin player save\n";
2616 for my $login (keys %cf::PLAYER) { 3805 for my $login (keys %cf::PLAYER) {
2617 my $pl = $cf::PLAYER{$login} or next; 3806 my $pl = $cf::PLAYER{$login} or next;
2618 $pl->valid or next; 3807 $pl->valid or next;
3808 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2619 $pl->save; 3809 $pl->save;
2620 } 3810 }
2621 warn "end emergency player save\n"; 3811 info "emergency_perl_save: end player save\n";
2622 3812
2623 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";
2624 for my $path (keys %cf::MAP) { 3816 for my $path (keys %cf::MAP) {
2625 my $map = $cf::MAP{$path} or next; 3817 my $map = $cf::MAP{$path} or next;
2626 $map->valid or next; 3818 $map->valid or next;
2627 $map->save; 3819 $map->save;
2628 } 3820 }
2629 warn "end emergency map save\n"; 3821 info "emergency_perl_save: end map save\n";
2630 3822
2631 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";
2632 BDB::db_env_txn_checkpoint $DB_ENV; 3826 BDB::db_env_txn_checkpoint $DB_ENV;
2633 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
2634 }; 3851 };
2635 3852
2636 warn "leave emergency perl save\n"; 3853 info "emergency_perl_save: leave\n";
2637} 3854}
2638 3855
2639sub post_cleanup { 3856sub post_cleanup {
2640 my ($make_core) = @_; 3857 my ($make_core) = @_;
2641 3858
3859 IO::AIO::flush;
3860
2642 warn Carp::longmess "post_cleanup backtrace" 3861 error Carp::longmess "post_cleanup backtrace"
2643 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 }
2644} 3891}
2645 3892
2646sub do_reload_perl() { 3893sub do_reload_perl() {
2647 # can/must only be called in main 3894 # can/must only be called in main
2648 if ($Coro::current != $Coro::main) { 3895 unless (in_main) {
2649 warn "can only reload from main coroutine"; 3896 error "can only reload from main coroutine";
2650 return; 3897 return;
2651 } 3898 }
2652 3899
2653 warn "reloading..."; 3900 return if $RELOAD++;
2654 3901
2655 warn "entering sync_job"; 3902 my $t1 = AE::time;
2656 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
2657 cf::sync_job { 3910 cf::sync_job {
2658 cf::write_runtime; # external watchdog should not bark
2659 cf::emergency_save; 3911 #cf::emergency_save;
2660 cf::write_runtime; # external watchdog should not bark
2661 3912
2662 warn "syncing database to disk";
2663 BDB::db_env_txn_checkpoint $DB_ENV;
2664
2665 # if anything goes wrong in here, we should simply crash as we already saved
2666
2667 warn "cancelling all WF_AUTOCANCEL watchers";
2668 for (Event::all_watchers) {
2669 $_->cancel if $_->data & WF_AUTOCANCEL;
2670 }
2671
2672 warn "flushing outstanding aio requests";
2673 for (;;) {
2674 BDB::flush;
2675 IO::AIO::flush;
2676 Coro::cede;
2677 last unless IO::AIO::nreqs || BDB::nreqs;
2678 warn "iterate...";
2679 }
2680
2681 ++$RELOAD;
2682
2683 warn "cancelling all extension coros"; 3913 trace "perl_reload: cancelling all extension coros";
2684 $_->cancel for values %EXT_CORO; 3914 $_->cancel for values %EXT_CORO;
2685 %EXT_CORO = (); 3915 %EXT_CORO = ();
2686 3916
2687 warn "removing commands"; 3917 trace "perl_reload: removing commands";
2688 %COMMAND = (); 3918 %COMMAND = ();
2689 3919
2690 warn "removing ext commands"; 3920 trace "perl_reload: removing ext/exti commands";
2691 %EXTCMD = (); 3921 %EXTCMD = ();
3922 %EXTICMD = ();
2692 3923
2693 warn "unloading/nuking all extensions"; 3924 trace "perl_reload: unloading/nuking all extensions";
2694 for my $pkg (@EXTS) { 3925 for my $pkg (@EXTS) {
2695 warn "... unloading $pkg"; 3926 trace "... unloading $pkg";
2696 3927
2697 if (my $cb = $pkg->can ("unload")) { 3928 if (my $cb = $pkg->can ("unload")) {
2698 eval { 3929 eval {
2699 $cb->($pkg); 3930 $cb->($pkg);
2700 1 3931 1
2701 } 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;
2702 } 3937 }
2703 3938
2704 warn "... nuking $pkg";
2705 Symbol::delete_package $pkg;
2706 }
2707
2708 warn "unloading all perl modules loaded from $LIBDIR"; 3939 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
2709 while (my ($k, $v) = each %INC) { 3940 while (my ($k, $v) = each %INC) {
2710 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3941 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2711 3942
2712 warn "... unloading $k"; 3943 trace "... unloading $k";
2713 delete $INC{$k}; 3944 delete $INC{$k};
2714 3945
2715 $k =~ s/\.pm$//; 3946 $k =~ s/\.pm$//;
2716 $k =~ s/\//::/g; 3947 $k =~ s/\//::/g;
2717 3948
2718 if (my $cb = $k->can ("unload_module")) { 3949 if (my $cb = $k->can ("unload_module")) {
2719 $cb->(); 3950 $cb->();
3951 }
3952
3953 clear_package $k;
2720 } 3954 }
2721 3955
2722 Symbol::delete_package $k;
2723 }
2724
2725 warn "getting rid of safe::, as good as possible"; 3956 trace "perl_reload: getting rid of safe::, as good as possible";
2726 Symbol::delete_package "safe::$_" 3957 clear_package "safe::$_"
2727 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);
2728 3959
2729 warn "unloading cf.pm \"a bit\""; 3960 trace "perl_reload: unloading cf.pm \"a bit\"";
2730 delete $INC{"cf.pm"}; 3961 delete $INC{"cf.pm"};
2731 delete $INC{"cf/pod.pm"}; 3962 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
2732 3963
2733 # don't, removes xs symbols, too, 3964 # don't, removes xs symbols, too,
2734 # and global variables created in xs 3965 # and global variables created in xs
2735 #Symbol::delete_package __PACKAGE__; 3966 #clear_package __PACKAGE__;
2736 3967
2737 warn "unload completed, starting to reload now"; 3968 info "perl_reload: unload completed, starting to reload now";
2738 3969
2739 warn "reloading cf.pm"; 3970 trace "perl_reload: reloading cf.pm";
2740 require cf; 3971 require cf;
2741 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3972 cf::_connect_to_perl_1;
2742 3973
2743 warn "loading config and database again"; 3974 trace "perl_reload: loading config and database again";
2744 cf::cfg_load; 3975 cf::reload_config;
2745 3976
2746 warn "loading extensions"; 3977 trace "perl_reload: loading extensions";
2747 cf::load_extensions; 3978 cf::load_extensions;
2748 3979
3980 if ($REATTACH_ON_RELOAD) {
2749 warn "reattaching attachments to objects/players"; 3981 trace "perl_reload: reattaching attachments to objects/players";
2750 _global_reattach; # objects, sockets 3982 _global_reattach; # objects, sockets
2751 warn "reattaching attachments to maps"; 3983 trace "perl_reload: reattaching attachments to maps";
2752 reattach $_ for values %MAP; 3984 reattach $_ for values %MAP;
2753 warn "reattaching attachments to players"; 3985 trace "perl_reload: reattaching attachments to players";
2754 reattach $_ for values %PLAYER; 3986 reattach $_ for values %PLAYER;
3987 }
2755 3988
2756 warn "leaving sync_job"; 3989 cf::_post_init 1;
2757 3990
3991 trace "perl_reload: leaving sync_job";
3992
2758 1 3993 1
2759 } or do { 3994 } or do {
2760 warn $@; 3995 error $@;
2761 warn "error while reloading, exiting."; 3996 cf::cleanup "perl_reload: error, exiting.";
2762 exit 1; 3997 };
3998
3999 --$RELOAD;
2763 }; 4000 }
2764 4001
2765 warn "reloaded"; 4002 $t1 = AE::time - $t1;
4003 info "perl_reload: completed in ${t1}s\n";
2766}; 4004};
2767 4005
2768our $RELOAD_WATCHER; # used only during reload 4006our $RELOAD_WATCHER; # used only during reload
2769 4007
2770sub reload_perl() { 4008sub reload_perl() {
2771 # doing reload synchronously and two reloads happen back-to-back, 4009 # doing reload synchronously and two reloads happen back-to-back,
2772 # coro crashes during coro_state_free->destroy here. 4010 # coro crashes during coro_state_free->destroy here.
2773 4011
2774 $RELOAD_WATCHER ||= Event->timer ( 4012 $RELOAD_WATCHER ||= cf::async {
2775 reentrant => 0, 4013 Coro::AIO::aio_wait cache_extensions;
2776 after => 0, 4014
2777 data => WF_AUTOCANCEL, 4015 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
2778 cb => sub {
2779 do_reload_perl; 4016 do_reload_perl;
2780 undef $RELOAD_WATCHER; 4017 undef $RELOAD_WATCHER;
2781 }, 4018 };
2782 ); 4019 };
2783} 4020}
2784 4021
2785register_command "reload" => sub { 4022register_command "reload" => sub {
2786 my ($who, $arg) = @_; 4023 my ($who, $arg) = @_;
2787 4024
2788 if ($who->flag (FLAG_WIZ)) { 4025 if ($who->flag (FLAG_WIZ)) {
2789 $who->message ("reloading server."); 4026 $who->message ("reloading server.");
4027 async {
4028 $Coro::current->{desc} = "perl_reload";
2790 async { reload_perl }; 4029 reload_perl;
4030 };
2791 } 4031 }
2792}; 4032};
2793 4033
2794unshift @INC, $LIBDIR; 4034#############################################################################
2795 4035
2796my $bug_warning = 0; 4036my $bug_warning = 0;
2797 4037
2798our @WAIT_FOR_TICK; 4038our @WAIT_FOR_TICK;
2799our @WAIT_FOR_TICK_BEGIN; 4039our @WAIT_FOR_TICK_BEGIN;
2800 4040
2801sub wait_for_tick { 4041sub wait_for_tick() {
2802 return unless $TICK_WATCHER->is_active;
2803 return if $Coro::current == $Coro::main; 4042 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2804 4043
2805 my $signal = new Coro::Signal; 4044 my $signal = new Coro::Signal;
2806 push @WAIT_FOR_TICK, $signal; 4045 push @WAIT_FOR_TICK, $signal;
2807 $signal->wait; 4046 $signal->wait;
2808} 4047}
2809 4048
2810sub wait_for_tick_begin { 4049sub wait_for_tick_begin() {
2811 return unless $TICK_WATCHER->is_active;
2812 return if $Coro::current == $Coro::main; 4050 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
2813 4051
2814 my $signal = new Coro::Signal; 4052 my $signal = new Coro::Signal;
2815 push @WAIT_FOR_TICK_BEGIN, $signal; 4053 push @WAIT_FOR_TICK_BEGIN, $signal;
2816 $signal->wait; 4054 $signal->wait;
2817} 4055}
2818 4056
2819$TICK_WATCHER = Event->timer ( 4057sub tick {
2820 reentrant => 0,
2821 parked => 1,
2822 prio => 0,
2823 at => $NEXT_TICK || $TICK,
2824 data => WF_AUTOCANCEL,
2825 cb => sub {
2826 if ($Coro::current != $Coro::main) { 4058 if ($Coro::current != $Coro::main) {
2827 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"
2828 unless ++$bug_warning > 10; 4060 unless ++$bug_warning > 10;
2829 return; 4061 return;
2830 } 4062 }
2831 4063
2832 $NOW = Event::time;
2833
2834 cf::server_tick; # one server iteration 4064 cf::server_tick; # one server iteration
2835 4065
2836 $RUNTIME += $TICK; 4066 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
2837 $NEXT_TICK += $TICK;
2838 4067
2839 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4068 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2840 $NEXT_RUNTIME_WRITE = $NOW + 10; 4069 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2841 Coro::async_pool { 4070 Coro::async_pool {
4071 $Coro::current->{desc} = "runtime saver";
2842 write_runtime 4072 write_runtime_sync
2843 or warn "ERROR: unable to write runtime file: $!"; 4073 or error "ERROR: unable to write runtime file: $!";
2844 };
2845 } 4074 };
4075 }
2846 4076
2847# my $AFTER = Event::time;
2848# warn $AFTER - $NOW;#d#
2849
2850 # if we are delayed by four ticks or more, skip them all
2851 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2852
2853 $TICK_WATCHER->at ($NEXT_TICK);
2854 $TICK_WATCHER->start;
2855
2856 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4077 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2857 $sig->send; 4078 $sig->send;
2858 } 4079 }
2859 while (my $sig = shift @WAIT_FOR_TICK) { 4080 while (my $sig = shift @WAIT_FOR_TICK) {
2860 $sig->send; 4081 $sig->send;
2861 }
2862
2863 _post_tick;
2864 }, 4082 }
2865); 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}
2866 4095
2867{ 4096{
2868 BDB::max_poll_time $TICK * 0.1; 4097 # configure BDB
2869 $BDB_POLL_WATCHER = Event->io ( 4098
2870 reentrant => 0,
2871 fd => BDB::poll_fileno,
2872 poll => 'r',
2873 prio => 0,
2874 data => WF_AUTOCANCEL,
2875 cb => \&BDB::poll_cb,
2876 );
2877 BDB::min_parallel 8; 4099 BDB::min_parallel 16;
2878 4100 BDB::max_poll_reqs $TICK * 0.1;
2879 BDB::set_sync_prepare { 4101 $AnyEvent::BDB::WATCHER->priority (1);
2880 my $status;
2881 my $current = $Coro::current;
2882 (
2883 sub {
2884 $status = $!;
2885 $current->ready; undef $current;
2886 },
2887 sub {
2888 Coro::schedule while defined $current;
2889 $! = $status;
2890 },
2891 )
2892 };
2893 4102
2894 unless ($DB_ENV) { 4103 unless ($DB_ENV) {
2895 $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);
2896 4110
2897 cf::sync_job { 4111 cf::sync_job {
2898 eval { 4112 eval {
2899 BDB::db_env_open 4113 BDB::db_env_open
2900 $DB_ENV, 4114 $DB_ENV,
… …
2902 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
2903 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4117 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2904 0666; 4118 0666;
2905 4119
2906 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4120 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2907
2908 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2909 $DB_ENV->set_lk_detect;
2910 }; 4121 };
2911 4122
2912 cf::cleanup "db_env_open(db): $@" if $@; 4123 cf::cleanup "db_env_open(db): $@" if $@;
2913 }; 4124 };
2914 } 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 };
2915} 4136}
2916 4137
2917{ 4138{
4139 # configure IO::AIO
4140
2918 IO::AIO::min_parallel 8; 4141 IO::AIO::min_parallel 8;
2919
2920 undef $Coro::AIO::WATCHER;
2921 IO::AIO::max_poll_time $TICK * 0.1; 4142 IO::AIO::max_poll_time $TICK * 0.1;
2922 $AIO_POLL_WATCHER = Event->io ( 4143 undef $AnyEvent::AIO::WATCHER;
2923 reentrant => 0,
2924 data => WF_AUTOCANCEL,
2925 fd => IO::AIO::poll_fileno,
2926 poll => 'r',
2927 prio => 6,
2928 cb => \&IO::AIO::poll_cb,
2929 );
2930} 4144}
2931 4145
2932my $_log_backtrace; 4146our $_log_backtrace;
4147our $_log_backtrace_last;
2933 4148
2934sub _log_backtrace { 4149sub _log_backtrace {
2935 my ($msg, @addr) = @_; 4150 my ($msg, @addr) = @_;
2936 4151
2937 $msg =~ s/\n//; 4152 $msg =~ s/\n$//;
2938 4153
4154 if ($_log_backtrace_last eq $msg) {
4155 LOG llevInfo, "[ABT] $msg\n";
4156 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
2939 # limit the # of concurrent backtraces 4157 # limit the # of concurrent backtraces
2940 if ($_log_backtrace < 2) { 4158 } elsif ($_log_backtrace < 2) {
4159 $_log_backtrace_last = $msg;
2941 ++$_log_backtrace; 4160 ++$_log_backtrace;
4161 my $perl_bt = Carp::longmess $msg;
2942 async { 4162 async {
4163 $Coro::current->{desc} = "abt $msg";
4164
2943 my @bt = fork_call { 4165 my @bt = fork_call {
2944 @addr = map { sprintf "%x", $_ } @addr; 4166 @addr = map { sprintf "%x", $_ } @addr;
2945 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 4167 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
2946 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 4168 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
2947 or die "addr2line: $!"; 4169 or die "addr2line: $!";
… …
2955 } 4177 }
2956 4178
2957 @funcs 4179 @funcs
2958 }; 4180 };
2959 4181
2960 LOG llevInfo, "[ABT] $msg\n"; 4182 LOG llevInfo, "[ABT] $perl_bt\n";
4183 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
2961 LOG llevInfo, "[ABT] $_\n" for @bt; 4184 LOG llevInfo, "[ABT] $_\n" for @bt;
2962 --$_log_backtrace; 4185 --$_log_backtrace;
2963 }; 4186 };
2964 } else { 4187 } else {
2965 LOG llevInfo, "[ABT] $msg\n"; 4188 LOG llevInfo, "[ABT] $msg\n";
2966 LOG llevInfo, "[ABT] [suppressed]\n"; 4189 LOG llevInfo, "[ABT] [overload, suppressed]\n";
2967 } 4190 }
2968} 4191}
2969 4192
2970# load additional modules 4193# load additional modules
2971use cf::pod; 4194require "cf/$_.pm" for @EXTRA_MODULES;
4195cf::_connect_to_perl_2;
2972 4196
2973END { cf::emergency_save } 4197END { cf::emergency_save }
2974 4198
29751 41991
2976 4200

Diff Legend

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