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.343 by root, Mon Aug 27 01:13:48 2007 UTC vs.
Revision 1.527 by root, Fri Apr 23 04:32:47 2010 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify it under
7# the terms of the Affero GNU General Public License as published by the
8# Free Software Foundation, either version 3 of the License, or (at your
9# option) any later version.
10#
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the Affero GNU General Public License
17# and the GNU General Public License along with this program. If not, see
18# <http://www.gnu.org/licenses/>.
19#
20# The authors can be reached via e-mail to <support@deliantra.net>
21#
22
1package cf; 23package cf;
2 24
25use 5.10.0;
3use utf8; 26use utf8;
4use strict; 27use strict qw(vars subs);
5 28
6use Symbol; 29use Symbol;
7use List::Util; 30use List::Util;
8use Socket; 31use Socket;
9use Storable; 32use EV;
10use Event;
11use Opcode; 33use Opcode;
12use Safe; 34use Safe;
13use Safe::Hole; 35use Safe::Hole;
36use Storable ();
37use Carp ();
14 38
39use Guard ();
15use Coro 3.64 (); 40use Coro ();
16use Coro::State; 41use Coro::State;
17use Coro::Handle; 42use Coro::Handle;
43use Coro::EV;
18use Coro::Event; 44use Coro::AnyEvent;
19use Coro::Timer; 45use Coro::Timer;
20use Coro::Signal; 46use Coro::Signal;
21use Coro::Semaphore; 47use Coro::Semaphore;
48use Coro::SemaphoreSet;
49use Coro::AnyEvent;
22use Coro::AIO; 50use Coro::AIO;
51use Coro::BDB 1.6;
23use Coro::Storable; 52use Coro::Storable;
24use Coro::Util (); 53use Coro::Util ();
25 54
26use JSON::XS 1.4 (); 55use JSON::XS 2.01 ();
27use BDB (); 56use BDB ();
28use Data::Dumper; 57use Data::Dumper;
29use Digest::MD5;
30use Fcntl; 58use Fcntl;
31use YAML::Syck (); 59use YAML::XS ();
32use IO::AIO 2.32 (); 60use IO::AIO ();
33use Time::HiRes; 61use Time::HiRes;
34use Compress::LZF; 62use Compress::LZF;
35use Digest::MD5 (); 63use Digest::MD5 ();
64
65AnyEvent::detect;
36 66
37# configure various modules to our taste 67# configure various modules to our taste
38# 68#
39$Storable::canonical = 1; # reduce rsync transfers 69$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 70Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
71
72$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
73
74# make sure c-lzf reinitialises itself
75Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 76Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42 77
43$Event::Eval = 1; # no idea why this is required, but it is 78# strictly for debugging
44 79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 80
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 82
52our %COMMAND = (); 83our %COMMAND = ();
53our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
56our %EXTCMD = (); 87our %EXTCMD = ();
57our %EXTICMD = (); 88our %EXTICMD = ();
58our %EXT_CORO = (); # coroutines bound to extensions 89our %EXT_CORO = (); # coroutines bound to extensions
59our %EXT_MAP = (); # pluggable maps 90our %EXT_MAP = (); # pluggable maps
60 91
61our $RELOAD; # number of reloads so far 92our $RELOAD; # number of reloads so far, non-zero while in reload
62our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS
95our %REFLECT; # set by us
63 96
64our $CONFDIR = confdir; 97our $CONFDIR = confdir;
65our $DATADIR = datadir; 98our $DATADIR = datadir;
66our $LIBDIR = "$DATADIR/ext"; 99our $LIBDIR = "$DATADIR/ext";
67our $PODDIR = "$DATADIR/pod"; 100our $PODDIR = "$DATADIR/pod";
68our $MAPDIR = "$DATADIR/" . mapdir; 101our $MAPDIR = "$DATADIR/" . mapdir;
69our $LOCALDIR = localdir; 102our $LOCALDIR = localdir;
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 103our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 105our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 106our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 107our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime";
110
111our %RESOURCE;
112
113our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 1000000;
115
116our $MAX_LINKS = 32; # how many chained exits to follow
117our $VERBOSE_IO = 0;#d#
75 118
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 119our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER;
78our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 120our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 121our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 122our $USE_FSYNC = 1; # use fsync to write maps - default on
83 123
124our $BDB_DEADLOCK_WATCHER;
125our $BDB_CHECKPOINT_WATCHER;
84our $BDB_POLL_WATCHER; 126our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 127our $DB_ENV;
128
129our @EXTRA_MODULES = qw(pod match mapscript);
86 130
87our %CFG; 131our %CFG;
88 132
89our $UPTIME; $UPTIME ||= time; 133our $UPTIME; $UPTIME ||= time;
90our $RUNTIME; 134our $RUNTIME;
135our $NOW;
91 136
92our %PLAYER; # all users 137our (%PLAYER, %PLAYER_LOADING); # all users
93our %MAP; # all maps 138our (%MAP, %MAP_LOADING ); # all maps
94our $LINK_MAP; # the special {link} map, which is always available 139our $LINK_MAP; # the special {link} map, which is always available
95 140
96# used to convert map paths into valid unix filenames by replacing / by ∕ 141# used to convert map paths into valid unix filenames by replacing / by ∕
97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 142our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98 143
99our $LOAD; # a number between 0 (idle) and 1 (too many objects) 144our $LOAD; # a number between 0 (idle) and 1 (too many objects)
100our $LOADAVG; # same thing, but with alpha-smoothing 145our $LOADAVG; # same thing, but with alpha-smoothing
146our $JITTER; # average jitter
101our $tick_start; # for load detecting purposes 147our $TICK_START; # for load detecting purposes
148
149our @POST_INIT;
150
151our $REATTACH_ON_RELOAD; # set to true to force object reattach on reload (slow)
152our $REALLY_UNLOOP; # never set to true, please :)
102 153
103binmode STDOUT; 154binmode STDOUT;
104binmode STDERR; 155binmode STDERR;
105 156
106# read virtual server time, if available 157# read virtual server time, if available
107unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 158unless ($RUNTIME || !-e $RUNTIMEFILE) {
108 open my $fh, "<", "$LOCALDIR/runtime" 159 open my $fh, "<", $RUNTIMEFILE
109 or die "unable to read runtime file: $!"; 160 or die "unable to read $RUNTIMEFILE file: $!";
110 $RUNTIME = <$fh> + 0.; 161 $RUNTIME = <$fh> + 0.;
111} 162}
163
164eval "sub TICK() { $TICK } 1" or die;
112 165
113mkdir $_ 166mkdir $_
114 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR; 167 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
115 168
116our $EMERGENCY_POSITION; 169our $EMERGENCY_POSITION;
117 170
118sub cf::map::normalise; 171sub cf::map::normalise;
172
173sub in_main() {
174 $Coro::current == $Coro::main
175}
176
177#############################################################################
178
179%REFLECT = ();
180for (@REFLECT) {
181 my $reflect = JSON::XS::decode_json $_;
182 $REFLECT{$reflect->{class}} = $reflect;
183}
184
185# this is decidedly evil
186$REFLECT{object}{flags} = { map +($_ => undef), grep $_, map /^FLAG_([A-Z0-9_]+)$/ && lc $1, keys %{"cf::"} };
119 187
120############################################################################# 188#############################################################################
121 189
122=head2 GLOBAL VARIABLES 190=head2 GLOBAL VARIABLES
123 191
159 227
160The raw value load value from the last tick. 228The raw value load value from the last tick.
161 229
162=item %cf::CFG 230=item %cf::CFG
163 231
164Configuration for the server, loaded from C</etc/crossfire/config>, or 232Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 233from wherever your confdir points to.
166 234
167=item cf::wait_for_tick, cf::wait_for_tick_begin 235=item cf::wait_for_tick, cf::wait_for_tick_begin
168 236
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 237These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
170returns directly I<after> the tick processing (and consequently, can only wake one process 238returns directly I<after> the tick processing (and consequently, can only wake one process
171per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 239per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
172 240
173=item @cf::INVOKE_RESULTS 241=item @cf::INVOKE_RESULTS
174 242
175This array contains the results of the last C<invoke ()> call. When 243This array contains the results of the last C<invoke ()> call. When
176C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 244C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
177that call. 245that call.
178 246
247=item %cf::REFLECT
248
249Contains, for each (C++) class name, a hash reference with information
250about object members (methods, scalars, arrays and flags) and other
251metadata, which is useful for introspection.
252
179=back 253=back
180 254
181=cut 255=cut
182 256
183BEGIN { 257$Coro::State::WARNHOOK = sub {
184 *CORE::GLOBAL::warn = sub {
185 my $msg = join "", @_; 258 my $msg = join "", @_;
186 259
187 $msg .= "\n" 260 $msg .= "\n"
188 unless $msg =~ /\n$/; 261 unless $msg =~ /\n$/;
189 262
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 263 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191 264
192 utf8::encode $msg;
193 LOG llevError, $msg; 265 LOG llevError, $msg;
194 }; 266};
195} 267
268$Coro::State::DIEHOOK = sub {
269 return unless $^S eq 0; # "eq", not "=="
270
271 warn Carp::longmess $_[0];
272
273 if (in_main) {#d#
274 warn "DIEHOOK called in main context, Coro bug?\n";#d#
275 return;#d#
276 }#d#
277
278 # kill coroutine otherwise
279 Coro::terminate
280};
196 281
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 282@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 283@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 284@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 285@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
207for my $pkg (qw( 292for my $pkg (qw(
208 cf::global cf::attachable 293 cf::global cf::attachable
209 cf::object cf::object::player 294 cf::object cf::object::player
210 cf::client cf::player 295 cf::client cf::player
211 cf::arch cf::living 296 cf::arch cf::living
297 cf::map cf::mapspace
212 cf::map cf::party cf::region 298 cf::party cf::region
213)) { 299)) {
214 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 300 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 301}
217 302
218$Event::DIED = sub { 303$EV::DIED = sub {
219 warn "error in event callback: @_"; 304 Carp::cluck "error in event callback: @_";
220}; 305};
221 306
222############################################################################# 307#############################################################################
223 308
224=head2 UTILITY FUNCTIONS 309=head2 UTILITY FUNCTIONS
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 331 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d 332 $d
248 } || "[unable to dump $_[0]: '$@']"; 333 } || "[unable to dump $_[0]: '$@']";
249} 334}
250 335
251=item $ref = cf::from_json $json 336=item $ref = cf::decode_json $json
252 337
253Converts a JSON string into the corresponding perl data structure. 338Converts a JSON string into the corresponding perl data structure.
254 339
255=item $json = cf::to_json $ref 340=item $json = cf::encode_json $ref
256 341
257Converts a perl data structure into its JSON representation. 342Converts a perl data structure into its JSON representation.
258 343
259=cut 344=cut
260 345
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 346our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262 347
263sub to_json ($) { $json_coder->encode ($_[0]) } 348sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 349sub decode_json($) { $json_coder->decode ($_[0]) }
350
351=item cf::post_init { BLOCK }
352
353Execute the given codeblock, I<after> all extensions have been (re-)loaded,
354but I<before> the server starts ticking again.
355
356The cdoeblock will have a single boolean argument to indicate whether this
357is a reload or not.
358
359=cut
360
361sub post_init(&) {
362 push @POST_INIT, shift;
363}
265 364
266=item cf::lock_wait $string 365=item cf::lock_wait $string
267 366
268Wait until the given lock is available. See cf::lock_acquire. 367Wait until the given lock is available. See cf::lock_acquire.
269 368
270=item my $lock = cf::lock_acquire $string 369=item my $lock = cf::lock_acquire $string
271 370
272Wait until the given lock is available and then acquires it and returns 371Wait until the given lock is available and then acquires it and returns
273a Coro::guard object. If the guard object gets destroyed (goes out of scope, 372a L<Guard> object. If the guard object gets destroyed (goes out of scope,
274for example when the coroutine gets canceled), the lock is automatically 373for example when the coroutine gets canceled), the lock is automatically
275returned. 374returned.
276 375
376Locks are *not* recursive, locking from the same coro twice results in a
377deadlocked coro.
378
277Lock names should begin with a unique identifier (for example, cf::map::find 379Lock names should begin with a unique identifier (for example, cf::map::find
278uses map_find and cf::map::load uses map_load). 380uses map_find and cf::map::load uses map_load).
279 381
280=item $locked = cf::lock_active $string 382=item $locked = cf::lock_active $string
281 383
282Return true if the lock is currently active, i.e. somebody has locked it. 384Return true if the lock is currently active, i.e. somebody has locked it.
283 385
284=cut 386=cut
285 387
286our %LOCK; 388our $LOCKS = new Coro::SemaphoreSet;
287 389
288sub lock_wait($) { 390sub lock_wait($) {
289 my ($key) = @_; 391 $LOCKS->wait ($_[0]);
290
291 # wait for lock, if any
292 while ($LOCK{$key}) {
293 push @{ $LOCK{$key} }, $Coro::current;
294 Coro::schedule;
295 }
296} 392}
297 393
298sub lock_acquire($) { 394sub lock_acquire($) {
299 my ($key) = @_; 395 $LOCKS->guard ($_[0])
300
301 # wait, to be sure we are not locked
302 lock_wait $key;
303
304 $LOCK{$key} = [];
305
306 Coro::guard {
307 # wake up all waiters, to be on the safe side
308 $_->ready for @{ delete $LOCK{$key} };
309 }
310} 396}
311 397
312sub lock_active($) { 398sub lock_active($) {
313 my ($key) = @_; 399 $LOCKS->count ($_[0]) < 1
314
315 ! ! $LOCK{$key}
316} 400}
317 401
318sub freeze_mainloop { 402sub freeze_mainloop {
319 return unless $TICK_WATCHER->is_active; 403 tick_inhibit_inc;
320 404
321 my $guard = Coro::guard { 405 &Guard::guard (\&tick_inhibit_dec);
322 $TICK_WATCHER->start; 406}
323 }; 407
324 $TICK_WATCHER->stop; 408=item cf::periodic $interval, $cb
325 $guard 409
410Like EV::periodic, but randomly selects a starting point so that the actions
411get spread over time.
412
413=cut
414
415sub periodic($$) {
416 my ($interval, $cb) = @_;
417
418 my $start = rand List::Util::min 180, $interval;
419
420 EV::periodic $start, $interval, 0, $cb
326} 421}
327 422
328=item cf::get_slot $time[, $priority[, $name]] 423=item cf::get_slot $time[, $priority[, $name]]
329 424
330Allocate $time seconds of blocking CPU time at priority C<$priority>: 425Allocate $time seconds of blocking CPU time at priority C<$priority>:
338 433
339=cut 434=cut
340 435
341our @SLOT_QUEUE; 436our @SLOT_QUEUE;
342our $SLOT_QUEUE; 437our $SLOT_QUEUE;
438our $SLOT_DECAY = 0.9;
343 439
344$SLOT_QUEUE->cancel if $SLOT_QUEUE; 440$SLOT_QUEUE->cancel if $SLOT_QUEUE;
345$SLOT_QUEUE = Coro::async { 441$SLOT_QUEUE = Coro::async {
442 $Coro::current->desc ("timeslot manager");
443
346 my $signal = new Coro::Signal; 444 my $signal = new Coro::Signal;
445 my $busy;
347 446
348 while () { 447 while () {
349 next_job: 448 next_job:
449
350 my $avail = cf::till_tick; 450 my $avail = cf::till_tick;
351 if ($avail > 0.01) { 451
352 for (0 .. $#SLOT_QUEUE) { 452 for (0 .. $#SLOT_QUEUE) {
353 if ($SLOT_QUEUE[$_][0] < $avail) { 453 if ($SLOT_QUEUE[$_][0] <= $avail) {
454 $busy = 0;
354 my $job = splice @SLOT_QUEUE, $_, 1, (); 455 my $job = splice @SLOT_QUEUE, $_, 1, ();
355 $job->[2]->send; 456 $job->[2]->send;
356 Coro::cede; 457 Coro::cede;
357 goto next_job; 458 goto next_job;
358 } 459 } else {
460 $SLOT_QUEUE[$_][0] *= $SLOT_DECAY;
359 } 461 }
360 } 462 }
361 463
362 if (@SLOT_QUEUE) { 464 if (@SLOT_QUEUE) {
363 # we do not use wait_For_tick() as it returns immediately when tick is inactive 465 # we do not use wait_for_tick() as it returns immediately when tick is inactive
364 push @cf::WAIT_FOR_TICK, $signal; 466 push @cf::WAIT_FOR_TICK, $signal;
365 $signal->wait; 467 $signal->wait;
366 } else { 468 } else {
469 $busy = 0;
367 Coro::schedule; 470 Coro::schedule;
368 } 471 }
369 } 472 }
370}; 473};
371 474
372sub get_slot($;$$) { 475sub get_slot($;$$) {
476 return if tick_inhibit || $Coro::current == $Coro::main;
477
373 my ($time, $pri, $name) = @_; 478 my ($time, $pri, $name) = @_;
374 479
375 $time = $TICK * .6 if $time > $TICK * .6; 480 $time = clamp $time, 0.01, $TICK * .6;
481
376 my $sig = new Coro::Signal; 482 my $sig = new Coro::Signal;
377 483
378 push @SLOT_QUEUE, [$time, $pri, $sig, $name]; 484 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
379 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE; 485 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
380 $SLOT_QUEUE->ready; 486 $SLOT_QUEUE->ready;
391 497
392BEGIN { *async = \&Coro::async_pool } 498BEGIN { *async = \&Coro::async_pool }
393 499
394=item cf::sync_job { BLOCK } 500=item cf::sync_job { BLOCK }
395 501
396The design of Crossfire TRT requires that the main coroutine ($Coro::main) 502The design of Deliantra requires that the main coroutine ($Coro::main)
397is always able to handle events or runnable, as Crossfire TRT is only 503is always able to handle events or runnable, as Deliantra is only
398partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 504partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
399acceptable. 505acceptable.
400 506
401If it must be done, put the blocking parts into C<sync_job>. This will run 507If it must be done, put the blocking parts into C<sync_job>. This will run
402the given BLOCK in another coroutine while waiting for the result. The 508the given BLOCK in another coroutine while waiting for the result. The
407 513
408sub sync_job(&) { 514sub sync_job(&) {
409 my ($job) = @_; 515 my ($job) = @_;
410 516
411 if ($Coro::current == $Coro::main) { 517 if ($Coro::current == $Coro::main) {
412 my $time = Event::time; 518 my $time = AE::time;
413 519
414 # this is the main coro, too bad, we have to block 520 # this is the main coro, too bad, we have to block
415 # till the operation succeeds, freezing the server :/ 521 # till the operation succeeds, freezing the server :/
416 522
417 # TODO: use suspend/resume instead 523 LOG llevError, Carp::longmess "sync job";#d#
418 # (but this is cancel-safe) 524
419 my $freeze_guard = freeze_mainloop; 525 my $freeze_guard = freeze_mainloop;
420 526
421 my $busy = 1; 527 my $busy = 1;
422 my @res; 528 my @res;
423 529
424 (async { 530 (async {
531 $Coro::current->desc ("sync job coro");
425 @res = eval { $job->() }; 532 @res = eval { $job->() };
426 warn $@ if $@; 533 warn $@ if $@;
427 undef $busy; 534 undef $busy;
428 })->prio (Coro::PRIO_MAX); 535 })->prio (Coro::PRIO_MAX);
429 536
430 while ($busy) { 537 while ($busy) {
431 Coro::cede or Event::one_event; 538 if (Coro::nready) {
539 Coro::cede_notself;
540 } else {
541 EV::loop EV::LOOP_ONESHOT;
432 } 542 }
543 }
433 544
434 $time = Event::time - $time; 545 my $time = AE::time - $time;
435 546
436 LOG llevError | logBacktrace, Carp::longmess "long sync job"
437 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
438
439 $tick_start += $time; # do not account sync jobs to server load 547 $TICK_START += $time; # do not account sync jobs to server load
440 548
441 wantarray ? @res : $res[0] 549 wantarray ? @res : $res[0]
442 } else { 550 } else {
443 # we are in another coroutine, how wonderful, everything just works 551 # we are in another coroutine, how wonderful, everything just works
444 552
469=item fork_call { }, $args 577=item fork_call { }, $args
470 578
471Executes the given code block with the given arguments in a seperate 579Executes the given code block with the given arguments in a seperate
472process, returning the results. Everything must be serialisable with 580process, returning the results. Everything must be serialisable with
473Coro::Storable. May, of course, block. Note that the executed sub may 581Coro::Storable. May, of course, block. Note that the executed sub may
474never block itself or use any form of Event handling. 582never block itself or use any form of event handling.
475 583
476=cut 584=cut
477 585
478sub fork_call(&@) { 586sub fork_call(&@) {
479 my ($cb, @args) = @_; 587 my ($cb, @args) = @_;
480 588
481 # we seemingly have to make a local copy of the whole thing, 589 # we seemingly have to make a local copy of the whole thing,
482 # otherwise perl prematurely frees the stuff :/ 590 # otherwise perl prematurely frees the stuff :/
483 # TODO: investigate and fix (liekly this will be rather laborious) 591 # TODO: investigate and fix (likely this will be rather laborious)
484 592
485 my @res = Coro::Util::fork_eval { 593 my @res = Coro::Util::fork_eval {
486 reset_signals; 594 reset_signals;
487 &$cb 595 &$cb
488 }, @args; 596 }, @args;
489 597
490 wantarray ? @res : $res[-1] 598 wantarray ? @res : $res[-1]
491} 599}
492 600
601sub objinfo {
602 (
603 "counter value" => cf::object::object_count,
604 "objects created" => cf::object::create_count,
605 "objects destroyed" => cf::object::destroy_count,
606 "freelist size" => cf::object::free_count,
607 "allocated objects" => cf::object::objects_size,
608 "active objects" => cf::object::actives_size,
609 )
610}
611
612=item $coin = coin_from_name $name
613
614=cut
615
616our %coin_alias = (
617 "silver" => "silvercoin",
618 "silvercoin" => "silvercoin",
619 "silvercoins" => "silvercoin",
620 "gold" => "goldcoin",
621 "goldcoin" => "goldcoin",
622 "goldcoins" => "goldcoin",
623 "platinum" => "platinacoin",
624 "platinumcoin" => "platinacoin",
625 "platinumcoins" => "platinacoin",
626 "platina" => "platinacoin",
627 "platinacoin" => "platinacoin",
628 "platinacoins" => "platinacoin",
629 "royalty" => "royalty",
630 "royalties" => "royalty",
631);
632
633sub coin_from_name($) {
634 $coin_alias{$_[0]}
635 ? cf::arch::find $coin_alias{$_[0]}
636 : undef
637}
638
493=item $value = cf::db_get $family => $key 639=item $value = cf::db_get $family => $key
494 640
495Returns a single value from the environment database. 641Returns a single value from the environment database.
496 642
497=item cf::db_put $family => $key => $value 643=item cf::db_put $family => $key => $value
498 644
499Stores the given C<$value> in the family. It can currently store binary 645Stores the given C<$value> in the family. It can currently store binary
500data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 646data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
501 647
648=item $db = cf::db_table "name"
649
650Create and/or open a new database table. The string must not be "db" and must be unique
651within each server.
652
502=cut 653=cut
654
655sub db_table($) {
656 my ($name) = @_;
657 my $db = BDB::db_create $DB_ENV;
658
659 eval {
660 $db->set_flags (BDB::CHKSUM);
661
662 utf8::encode $name;
663 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
664 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
665 cf::cleanup "db_open(db): $!" if $!;
666 };
667 cf::cleanup "db_open(db): $@" if $@;
668
669 $db
670}
503 671
504our $DB; 672our $DB;
505 673
506sub db_init { 674sub db_init {
507 unless ($DB) {
508 $DB = BDB::db_create $DB_ENV;
509
510 cf::sync_job { 675 cf::sync_job {
511 eval { 676 $DB ||= db_table "db";
512 $DB->set_flags (BDB::CHKSUM);
513
514 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
515 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
516 cf::cleanup "db_open(db): $!" if $!;
517 };
518 cf::cleanup "db_open(db): $@" if $@;
519 };
520 } 677 };
521} 678}
522 679
523sub db_get($$) { 680sub db_get($$) {
524 my $key = "$_[0]/$_[1]"; 681 my $key = "$_[0]/$_[1]";
525 682
575 if (1) { 732 if (1) {
576 $md5 = 733 $md5 =
577 join "\x00", 734 join "\x00",
578 $processversion, 735 $processversion,
579 map { 736 map {
580 Coro::cede; 737 cf::cede_to_tick;
581 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 738 ($src->[$_], Digest::MD5::md5_hex $data[$_])
582 } 0.. $#$src; 739 } 0.. $#$src;
583 740
584 741
585 my $dbmd5 = db_get cache => "$id/md5"; 742 my $dbmd5 = db_get cache => "$id/md5";
623 780
624############################################################################# 781#############################################################################
625 782
626=head2 ATTACHABLE OBJECTS 783=head2 ATTACHABLE OBJECTS
627 784
628Many objects in crossfire are so-called attachable objects. That means you can 785Many objects in deliantra are so-called attachable objects. That means you can
629attach callbacks/event handlers (a collection of which is called an "attachment") 786attach callbacks/event handlers (a collection of which is called an "attachment")
630to it. All such attachable objects support the following methods. 787to it. All such attachable objects support the following methods.
631 788
632In the following description, CLASS can be any of C<global>, C<object> 789In the following description, CLASS can be any of C<global>, C<object>
633C<player>, C<client> or C<map> (i.e. the attachable objects in 790C<player>, C<client> or C<map> (i.e. the attachable objects in
634Crossfire TRT). 791Deliantra).
635 792
636=over 4 793=over 4
637 794
638=item $attachable->attach ($attachment, key => $value...) 795=item $attachable->attach ($attachment, key => $value...)
639 796
683=item cf::CLASS::attachment $name, ... 840=item cf::CLASS::attachment $name, ...
684 841
685Register an attachment by C<$name> through which attachable objects of the 842Register an attachment by C<$name> through which attachable objects of the
686given CLASS can refer to this attachment. 843given CLASS can refer to this attachment.
687 844
688Some classes such as crossfire maps and objects can specify attachments 845Some classes such as deliantra maps and objects can specify attachments
689that are attached at load/instantiate time, thus the need for a name. 846that are attached at load/instantiate time, thus the need for a name.
690 847
691These calls expect any number of the following handler/hook descriptions: 848These calls expect any number of the following handler/hook descriptions:
692 849
693=over 4 850=over 4
921 } 1078 }
922 1079
923 0 1080 0
924} 1081}
925 1082
926=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1083=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
927 1084
928=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1085=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
929 1086
930Generate an object-specific event with the given arguments. 1087Generate an object-specific event with the given arguments.
931 1088
937 1094
938=cut 1095=cut
939 1096
940############################################################################# 1097#############################################################################
941# object support 1098# object support
942#
943 1099
1100sub _object_equal($$);
1101sub _object_equal($$) {
1102 my ($a, $b) = @_;
1103
1104 return 0 unless (ref $a) eq (ref $b);
1105
1106 if ("HASH" eq ref $a) {
1107 my @ka = keys %$a;
1108 my @kb = keys %$b;
1109
1110 return 0 if @ka != @kb;
1111
1112 for (0 .. $#ka) {
1113 return 0 unless $ka[$_] eq $kb[$_];
1114 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1115 }
1116
1117 } elsif ("ARRAY" eq ref $a) {
1118
1119 return 0 if @$a != @$b;
1120
1121 for (0 .. $#$a) {
1122 return 0 unless _object_equal $a->[$_], $b->[$_];
1123 }
1124
1125 } elsif ($a ne $b) {
1126 return 0;
1127 }
1128
1129 1
1130}
1131
1132our $SLOW_MERGES;#d#
944sub _can_merge { 1133sub _can_merge {
945 my ($ob1, $ob2) = @_; 1134 my ($ob1, $ob2) = @_;
946 1135
947 local $Storable::canonical = 1; 1136 ++$SLOW_MERGES;#d#
948 my $fob1 = Storable::freeze $ob1;
949 my $fob2 = Storable::freeze $ob2;
950 1137
951 $fob1 eq $fob2 1138 # we do the slow way here
1139 return _object_equal $ob1, $ob2
952} 1140}
953 1141
954sub reattach { 1142sub reattach {
955 # basically do the same as instantiate, without calling instantiate 1143 # basically do the same as instantiate, without calling instantiate
956 my ($obj) = @_; 1144 my ($obj) = @_;
957 1145
1146 # no longer needed after getting rid of delete_package?
958 bless $obj, ref $obj; # re-bless in case extensions have been reloaded 1147 #bless $obj, ref $obj; # re-bless in case extensions have been reloaded
959 1148
960 my $registry = $obj->registry; 1149 my $registry = $obj->registry;
961 1150
962 @$registry = (); 1151 @$registry = ();
963 1152
978cf::attachable->attach ( 1167cf::attachable->attach (
979 prio => -1000000, 1168 prio => -1000000,
980 on_instantiate => sub { 1169 on_instantiate => sub {
981 my ($obj, $data) = @_; 1170 my ($obj, $data) = @_;
982 1171
983 $data = from_json $data; 1172 $data = decode_json $data;
984 1173
985 for (@$data) { 1174 for (@$data) {
986 my ($name, $args) = @$_; 1175 my ($name, $args) = @$_;
987 1176
988 $obj->attach ($name, %{$args || {} }); 1177 $obj->attach ($name, %{$args || {} });
1004sub object_freezer_save { 1193sub object_freezer_save {
1005 my ($filename, $rdata, $objs) = @_; 1194 my ($filename, $rdata, $objs) = @_;
1006 1195
1007 sync_job { 1196 sync_job {
1008 if (length $$rdata) { 1197 if (length $$rdata) {
1198 utf8::decode (my $decname = $filename);
1009 warn sprintf "saving %s (%d,%d)\n", 1199 warn sprintf "saving %s (%d,%d)\n",
1010 $filename, length $$rdata, scalar @$objs; 1200 $decname, length $$rdata, scalar @$objs
1201 if $VERBOSE_IO;
1011 1202
1012 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1203 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1013 chmod SAVE_MODE, $fh; 1204 aio_chmod $fh, SAVE_MODE;
1014 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1205 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1015 aio_fsync $fh if $cf::USE_FSYNC; 1206 if ($cf::USE_FSYNC) {
1207 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;
1208 aio_fsync $fh;
1209 }
1016 close $fh; 1210 aio_close $fh;
1017 1211
1018 if (@$objs) { 1212 if (@$objs) {
1019 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1213 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1020 chmod SAVE_MODE, $fh; 1214 aio_chmod $fh, SAVE_MODE;
1021 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1215 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1022 aio_write $fh, 0, (length $data), $data, 0; 1216 aio_write $fh, 0, (length $data), $data, 0;
1023 aio_fsync $fh if $cf::USE_FSYNC; 1217 if ($cf::USE_FSYNC) {
1218 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;
1219 aio_fsync $fh;
1220 }
1024 close $fh; 1221 aio_close $fh;
1025 aio_rename "$filename.pst~", "$filename.pst"; 1222 aio_rename "$filename.pst~", "$filename.pst";
1026 } 1223 }
1027 } else { 1224 } else {
1028 aio_unlink "$filename.pst"; 1225 aio_unlink "$filename.pst";
1029 } 1226 }
1030 1227
1031 aio_rename "$filename~", $filename; 1228 aio_rename "$filename~", $filename;
1229
1230 $filename =~ s%/[^/]+$%%;
1231 aio_pathsync $filename if $cf::USE_FSYNC;
1032 } else { 1232 } else {
1033 warn "FATAL: $filename~: $!\n"; 1233 warn "unable to save objects: $filename~: $!\n";
1034 } 1234 }
1035 } else { 1235 } else {
1036 aio_unlink $filename; 1236 aio_unlink $filename;
1037 aio_unlink "$filename.pst"; 1237 aio_unlink "$filename.pst";
1038 } 1238 }
1039 } 1239 };
1040} 1240}
1041 1241
1042sub object_freezer_as_string { 1242sub object_freezer_as_string {
1043 my ($rdata, $objs) = @_; 1243 my ($rdata, $objs) = @_;
1044 1244
1056 or return; 1256 or return;
1057 1257
1058 unless (aio_stat "$filename.pst") { 1258 unless (aio_stat "$filename.pst") {
1059 (aio_load "$filename.pst", $av) >= 0 1259 (aio_load "$filename.pst", $av) >= 0
1060 or return; 1260 or return;
1261
1061 $av = eval { (Storable::thaw $av)->{objs} }; 1262 my $st = eval { Coro::Storable::thaw $av };
1263 $av = $st->{objs};
1062 } 1264 }
1063 1265
1266 utf8::decode (my $decname = $filename);
1064 warn sprintf "loading %s (%d)\n", 1267 warn sprintf "loading %s (%d,%d)\n",
1065 $filename, length $data, scalar @{$av || []}; 1268 $decname, length $data, scalar @{$av || []}
1269 if $VERBOSE_IO;
1270
1066 return ($data, $av); 1271 ($data, $av)
1067} 1272}
1068 1273
1069=head2 COMMAND CALLBACKS 1274=head2 COMMAND CALLBACKS
1070 1275
1071=over 4 1276=over 4
1125 my ($name, $cb) = @_; 1330 my ($name, $cb) = @_;
1126 1331
1127 $EXTICMD{$name} = $cb; 1332 $EXTICMD{$name} = $cb;
1128} 1333}
1129 1334
1335use File::Glob ();
1336
1130cf::player->attach ( 1337cf::player->attach (
1131 on_command => sub { 1338 on_unknown_command => sub {
1132 my ($pl, $name, $params) = @_; 1339 my ($pl, $name, $params) = @_;
1133 1340
1134 my $cb = $COMMAND{$name} 1341 my $cb = $COMMAND{$name}
1135 or return; 1342 or return;
1136 1343
1166 1373
1167 cf::override; 1374 cf::override;
1168 }, 1375 },
1169); 1376);
1170 1377
1378# "readahead" all extensions
1379sub cache_extensions {
1380 my $grp = IO::AIO::aio_group;
1381
1382 add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
1383 for (grep /\.ext$/, @{$_[0]}) {
1384 add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
1385 }
1386 };
1387
1388 $grp
1389}
1390
1171sub load_extensions { 1391sub load_extensions {
1172 cf::sync_job { 1392 cf::sync_job {
1173 my %todo; 1393 my %todo;
1174 1394
1175 for my $path (<$LIBDIR/*.ext>) { 1395 for my $path (<$LIBDIR/*.ext>) {
1194 1414
1195 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1415 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1196 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1416 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1197 1417
1198 $ext{source} = 1418 $ext{source} =
1199 "package $pkg; use strict; use utf8;\n" 1419 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n"
1200 . "#line 1 \"$path\"\n{\n" 1420 . "#line 1 \"$path\"\n{\n"
1201 . $source 1421 . $source
1202 . "\n};\n1"; 1422 . "\n};\n1";
1203 1423
1204 $todo{$base} = \%ext; 1424 $todo{$base} = \%ext;
1205 } 1425 }
1206 1426
1427 my $pass = 0;
1207 my %done; 1428 my %done;
1208 while (%todo) { 1429 while (%todo) {
1209 my $progress; 1430 my $progress;
1210 1431
1432 ++$pass;
1433
1434 ext:
1211 while (my ($k, $v) = each %todo) { 1435 while (my ($k, $v) = each %todo) {
1212 for (split /,\s*/, $v->{meta}{depends}) { 1436 for (split /,\s*/, $v->{meta}{depends}) {
1213 goto skip 1437 next ext
1214 unless exists $done{$_}; 1438 unless exists $done{$_};
1215 } 1439 }
1216 1440
1217 warn "... loading '$k' into '$v->{pkg}'\n"; 1441 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1218 1442
1219 unless (eval $v->{source}) { 1443 my $active = eval $v->{source};
1444
1445 if (length $@) {
1220 my $msg = $@ ? "$v->{path}: $@\n" 1446 warn "$v->{path}: $@\n";
1221 : "$v->{base}: extension inactive.\n";
1222 1447
1448 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1223 if (exists $v->{meta}{mandatory}) { 1449 if exists $v->{meta}{mandatory};
1224 warn $msg; 1450
1225 warn "mandatory extension failed to load, exiting.\n"; 1451 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1226 exit 1; 1452 delete $todo{$k};
1227 } 1453 } else {
1228 1454 $done{$k} = delete $todo{$k};
1229 warn $msg; 1455 push @EXTS, $v->{pkg};
1456 $progress = 1;
1457
1458 warn "$v->{base}: extension inactive.\n"
1459 unless $active;
1230 } 1460 }
1231
1232 $done{$k} = delete $todo{$k};
1233 push @EXTS, $v->{pkg};
1234 $progress = 1;
1235 } 1461 }
1236 1462
1237 skip: 1463 unless ($progress) {
1238 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n" 1464 warn "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n";
1239 unless $progress; 1465
1466 while (my ($k, $v) = each %todo) {
1467 cf::cleanup "mandatory extension '$k' has unresolved dependencies, exiting."
1468 if exists $v->{meta}{mandatory};
1469 }
1470 }
1240 } 1471 }
1241 }; 1472 };
1242} 1473}
1243 1474
1244############################################################################# 1475#############################################################################
1245 1476
1246=back 1477=back
1247 1478
1248=head2 CORE EXTENSIONS 1479=head2 CORE EXTENSIONS
1249 1480
1250Functions and methods that extend core crossfire objects. 1481Functions and methods that extend core deliantra objects.
1251 1482
1252=cut 1483=cut
1253 1484
1254package cf::player; 1485package cf::player;
1255 1486
1256use Coro::AIO; 1487use Coro::AIO;
1257 1488
1258=head3 cf::player 1489=head3 cf::player
1259 1490
1260=over 4 1491=over 4
1492
1493=item cf::player::num_playing
1494
1495Returns the official number of playing players, as per the Crossfire metaserver rules.
1496
1497=cut
1498
1499sub num_playing {
1500 scalar grep
1501 $_->ob->map
1502 && !$_->hidden
1503 && !$_->ob->flag (cf::FLAG_WIZ),
1504 cf::player::list
1505}
1261 1506
1262=item cf::player::find $login 1507=item cf::player::find $login
1263 1508
1264Returns the given player object, loading it if necessary (might block). 1509Returns the given player object, loading it if necessary (might block).
1265 1510
1284 1529
1285sub exists($) { 1530sub exists($) {
1286 my ($login) = @_; 1531 my ($login) = @_;
1287 1532
1288 $cf::PLAYER{$login} 1533 $cf::PLAYER{$login}
1289 or cf::sync_job { !aio_stat path $login } 1534 or !aio_stat path $login
1290} 1535}
1291 1536
1292sub find($) { 1537sub find($) {
1293 return $cf::PLAYER{$_[0]} || do { 1538 return $cf::PLAYER{$_[0]} || do {
1294 my $login = $_[0]; 1539 my $login = $_[0];
1301 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1546 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1302 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1547 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1303 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1548 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1304 aio_unlink +(playerdir $login) . "/$login.pl"; 1549 aio_unlink +(playerdir $login) . "/$login.pl";
1305 1550
1306 my $pl = load_pl path $login 1551 my $f = new_from_file cf::object::thawer path $login
1307 or return; 1552 or return;
1553
1554 my $pl = cf::player::load_pl $f
1555 or return;
1556
1557 local $cf::PLAYER_LOADING{$login} = $pl;
1558 $f->resolve_delayed_derefs;
1308 $cf::PLAYER{$login} = $pl 1559 $cf::PLAYER{$login} = $pl
1309 } 1560 }
1310 } 1561 }
1311} 1562}
1563
1564cf::player->attach (
1565 on_load => sub {
1566 my ($pl, $path) = @_;
1567
1568 # restore slots saved in save, below
1569 my $slots = delete $pl->{_slots};
1570
1571 $pl->ob->current_weapon ($slots->[0]);
1572 $pl->combat_ob ($slots->[1]);
1573 $pl->ranged_ob ($slots->[2]);
1574 },
1575);
1312 1576
1313sub save($) { 1577sub save($) {
1314 my ($pl) = @_; 1578 my ($pl) = @_;
1315 1579
1316 return if $pl->{deny_save}; 1580 return if $pl->{deny_save};
1321 return if $pl->{deny_save}; 1585 return if $pl->{deny_save};
1322 1586
1323 aio_mkdir playerdir $pl, 0770; 1587 aio_mkdir playerdir $pl, 0770;
1324 $pl->{last_save} = $cf::RUNTIME; 1588 $pl->{last_save} = $cf::RUNTIME;
1325 1589
1590 cf::get_slot 0.01;
1591
1592 # save slots, to be restored later
1593 local $pl->{_slots} = [$pl->ob->current_weapon, $pl->combat_ob, $pl->ranged_ob];
1594
1326 $pl->save_pl ($path); 1595 $pl->save_pl ($path);
1327 Coro::cede; 1596 cf::cede_to_tick;
1328} 1597}
1329 1598
1330sub new($) { 1599sub new($) {
1331 my ($login) = @_; 1600 my ($login) = @_;
1332 1601
1361 my ($pl) = @_; 1630 my ($pl) = @_;
1362 1631
1363 my $name = $pl->ob->name; 1632 my $name = $pl->ob->name;
1364 1633
1365 $pl->{deny_save} = 1; 1634 $pl->{deny_save} = 1;
1366 $pl->password ("*"); # this should lock out the player until we nuked the dir 1635 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1367 1636
1368 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1637 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1369 $pl->deactivate; 1638 $pl->deactivate;
1639 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1640 $pl->ob->check_score;
1370 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1641 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1371 $pl->ns->destroy if $pl->ns; 1642 $pl->ns->destroy if $pl->ns;
1372 1643
1373 my $path = playerdir $pl; 1644 my $path = playerdir $pl;
1374 my $temp = "$path~$cf::RUNTIME~deleting~"; 1645 my $temp = "$path~$cf::RUNTIME~deleting~";
1410 or return []; 1681 or return [];
1411 1682
1412 my @logins; 1683 my @logins;
1413 1684
1414 for my $login (@$dirs) { 1685 for my $login (@$dirs) {
1686 my $path = path $login;
1687
1688 # a .pst is a dead give-away for a valid player
1689 # if no pst file found, open and chekc for blocked users
1690 if (aio_stat "$path.pst") {
1415 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1691 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1416 aio_read $fh, 0, 512, my $buf, 0 or next; 1692 aio_read $fh, 0, 512, my $buf, 0 or next;
1417 $buf !~ /^password -------------$/m or next; # official not-valid tag 1693 $buf !~ /^password -------------$/m or next; # official not-valid tag
1694 }
1418 1695
1419 utf8::decode $login; 1696 utf8::decode $login;
1420 push @logins, $login; 1697 push @logins, $login;
1421 } 1698 }
1422 1699
1423 \@logins 1700 \@logins
1424} 1701}
1425 1702
1426=item $player->maps 1703=item $player->maps
1704
1705=item cf::player::maps $login
1427 1706
1428Returns an arrayref of map paths that are private for this 1707Returns an arrayref of map paths that are private for this
1429player. May block. 1708player. May block.
1430 1709
1431=cut 1710=cut
1449 } 1728 }
1450 1729
1451 \@paths 1730 \@paths
1452} 1731}
1453 1732
1454=item $protocol_xml = $player->expand_cfpod ($crossfire_pod) 1733=item $protocol_xml = $player->expand_cfpod ($cfpod)
1455 1734
1456Expand crossfire pod fragments into protocol xml. 1735Expand deliantra pod fragments into protocol xml.
1457
1458=cut
1459
1460sub expand_cfpod {
1461 ((my $self), (local $_)) = @_;
1462
1463 # escape & and <
1464 s/&/&amp;/g;
1465 s/(?<![BIUGH])</&lt;/g;
1466
1467 # this is buggy, it needs to properly take care of nested <'s
1468
1469 1 while
1470 # replace B<>, I<>, U<> etc.
1471 s/B<([^\>]*)>/<b>$1<\/b>/
1472 || s/I<([^\>]*)>/<i>$1<\/i>/
1473 || s/U<([^\>]*)>/<u>$1<\/u>/
1474 # replace G<male|female> tags
1475 || s{G<([^>|]*)\|([^>]*)>}{
1476 $self->gender ? $2 : $1
1477 }ge
1478 # replace H<hint text>
1479 || s{H<([^\>]*)>}
1480 {
1481 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1482 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1483 "")
1484 [$self->{hintmode}]
1485 }ge;
1486
1487 # create single paragraphs (very hackish)
1488 s/(?<=\S)\n(?=\w)/ /g;
1489
1490 # compress some whitespace
1491 s/\s+\n/\n/g; # ws line-ends
1492 s/\n\n+/\n/g; # double lines
1493 s/^\n+//; # beginning lines
1494 s/\n+$//; # ending lines
1495
1496 $_
1497}
1498
1499sub hintmode {
1500 $_[0]{hintmode} = $_[1] if @_ > 1;
1501 $_[0]{hintmode}
1502}
1503 1736
1504=item $player->ext_reply ($msgid, @msg) 1737=item $player->ext_reply ($msgid, @msg)
1505 1738
1506Sends an ext reply to the player. 1739Sends an ext reply to the player.
1507 1740
1539 1772
1540=cut 1773=cut
1541 1774
1542sub find_by_path($) { 1775sub find_by_path($) {
1543 my ($path) = @_; 1776 my ($path) = @_;
1777
1778 $path =~ s/^~[^\/]*//; # skip ~login
1544 1779
1545 my ($match, $specificity); 1780 my ($match, $specificity);
1546 1781
1547 for my $region (list) { 1782 for my $region (list) {
1548 if ($region->{match} && $path =~ $region->{match}) { 1783 if ($region->{match} && $path =~ $region->{match}) {
1574our $MAX_RESET = 3600; 1809our $MAX_RESET = 3600;
1575our $DEFAULT_RESET = 3000; 1810our $DEFAULT_RESET = 3000;
1576 1811
1577sub generate_random_map { 1812sub generate_random_map {
1578 my ($self, $rmp) = @_; 1813 my ($self, $rmp) = @_;
1814
1815 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1816
1579 # mit "rum" bekleckern, nicht 1817 # mit "rum" bekleckern, nicht
1580 $self->_create_random_map ( 1818 $self->_create_random_map (
1581 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1819 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1582 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1820 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1583 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1821 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1584 $rmp->{exit_on_final_map}, 1822 $rmp->{exit_on_final_map},
1585 $rmp->{xsize}, $rmp->{ysize}, 1823 $rmp->{xsize}, $rmp->{ysize},
1586 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1824 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1587 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1825 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1609 1847
1610 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1848 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1611} 1849}
1612 1850
1613# also paths starting with '/' 1851# also paths starting with '/'
1614$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1852$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1615 1853
1616sub thawer_merge { 1854sub thawer_merge {
1617 my ($self, $merge) = @_; 1855 my ($self, $merge) = @_;
1618 1856
1619 # we have to keep some variables in memory intact 1857 # we have to keep some variables in memory intact
1705 1943
1706# the temporary/swap location 1944# the temporary/swap location
1707sub save_path { 1945sub save_path {
1708 my ($self) = @_; 1946 my ($self) = @_;
1709 1947
1710 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1948 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1711 "$TMPDIR/$path.map" 1949 "$TMPDIR/$path.map"
1712} 1950}
1713 1951
1714# the unique path, undef == no special unique path 1952# the unique path, undef == no special unique path
1715sub uniq_path { 1953sub uniq_path {
1716 my ($self) = @_; 1954 my ($self) = @_;
1717 1955
1718 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1956 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1719 "$UNIQUEDIR/$path" 1957 "$UNIQUEDIR/$path"
1720}
1721
1722# and all this just because we cannot iterate over
1723# all maps in C++...
1724sub change_all_map_light {
1725 my ($change) = @_;
1726
1727 $_->change_map_light ($change)
1728 for grep $_->outdoor, values %cf::MAP;
1729} 1958}
1730 1959
1731sub decay_objects { 1960sub decay_objects {
1732 my ($self) = @_; 1961 my ($self) = @_;
1733 1962
1746 1975
1747sub load_header_from($) { 1976sub load_header_from($) {
1748 my ($self, $path) = @_; 1977 my ($self, $path) = @_;
1749 1978
1750 utf8::encode $path; 1979 utf8::encode $path;
1751 #aio_open $path, O_RDONLY, 0 1980 my $f = new_from_file cf::object::thawer $path
1752 # or return;
1753
1754 $self->_load_header ($path)
1755 or return; 1981 or return;
1982
1983 $self->_load_header ($f)
1984 or return;
1985
1986 local $MAP_LOADING{$self->{path}} = $self;
1987 $f->resolve_delayed_derefs;
1756 1988
1757 $self->{load_path} = $path; 1989 $self->{load_path} = $path;
1758 1990
1759 1 1991 1
1760} 1992}
1814sub find { 2046sub find {
1815 my ($path, $origin) = @_; 2047 my ($path, $origin) = @_;
1816 2048
1817 $path = normalise $path, $origin && $origin->path; 2049 $path = normalise $path, $origin && $origin->path;
1818 2050
2051 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1819 cf::lock_wait "map_find:$path"; 2052 my $guard2 = cf::lock_acquire "map_find:$path";
1820 2053
1821 $cf::MAP{$path} || do { 2054 $cf::MAP{$path} || do {
1822 my $guard = cf::lock_acquire "map_find:$path";
1823 my $map = new_from_path cf::map $path 2055 my $map = new_from_path cf::map $path
1824 or return; 2056 or return;
1825 2057
1826 $map->{last_save} = $cf::RUNTIME; 2058 $map->{last_save} = $cf::RUNTIME;
1827 2059
1829 or return; 2061 or return;
1830 2062
1831 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 2063 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1832 # doing this can freeze the server in a sync job, obviously 2064 # doing this can freeze the server in a sync job, obviously
1833 #$cf::WAIT_FOR_TICK->wait; 2065 #$cf::WAIT_FOR_TICK->wait;
2066 undef $guard2;
2067 undef $guard1;
1834 $map->reset; 2068 $map->reset;
1835 undef $guard;
1836 return find $path; 2069 return find $path;
1837 } 2070 }
1838 2071
1839 $cf::MAP{$path} = $map 2072 $cf::MAP{$path} = $map
1840 } 2073 }
1841} 2074}
1842 2075
1843sub pre_load { } 2076sub pre_load { }
1844sub post_load { } 2077#sub post_load { } # XS
1845 2078
1846sub load { 2079sub load {
1847 my ($self) = @_; 2080 my ($self) = @_;
1848 2081
1849 local $self->{deny_reset} = 1; # loading can take a long time 2082 local $self->{deny_reset} = 1; # loading can take a long time
1850 2083
1851 my $path = $self->{path}; 2084 my $path = $self->{path};
1852 2085
1853 { 2086 {
1854 my $guard = cf::lock_acquire "map_load:$path"; 2087 my $guard = cf::lock_acquire "map_data:$path";
1855 2088
2089 return unless $self->valid;
1856 return if $self->in_memory != cf::MAP_SWAPPED; 2090 return unless $self->in_memory == cf::MAP_SWAPPED;
1857 2091
1858 $self->in_memory (cf::MAP_LOADING); 2092 $self->in_memory (cf::MAP_LOADING);
1859 2093
1860 $self->alloc; 2094 $self->alloc;
1861 2095
1862 $self->pre_load; 2096 $self->pre_load;
1863 Coro::cede; 2097 cf::cede_to_tick;
1864 2098
2099 my $f = new_from_file cf::object::thawer $self->{load_path};
2100 $f->skip_block;
1865 $self->_load_objects ($self->{load_path}, 1) 2101 $self->_load_objects ($f)
1866 or return; 2102 or return;
1867 2103
1868 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2104 $self->post_load_original
1869 if delete $self->{load_original}; 2105 if delete $self->{load_original};
1870 2106
1871 if (my $uniq = $self->uniq_path) { 2107 if (my $uniq = $self->uniq_path) {
1872 utf8::encode $uniq; 2108 utf8::encode $uniq;
1873 if (aio_open $uniq, O_RDONLY, 0) { 2109 unless (aio_stat $uniq) {
2110 if (my $f = new_from_file cf::object::thawer $uniq) {
1874 $self->clear_unique_items; 2111 $self->clear_unique_items;
1875 $self->_load_objects ($uniq, 0); 2112 $self->_load_objects ($f);
2113 $f->resolve_delayed_derefs;
2114 }
1876 } 2115 }
1877 } 2116 }
1878 2117
1879 Coro::cede; 2118 $f->resolve_delayed_derefs;
2119
2120 cf::cede_to_tick;
1880 # now do the right thing for maps 2121 # now do the right thing for maps
1881 $self->link_multipart_objects; 2122 $self->link_multipart_objects;
1882 $self->difficulty ($self->estimate_difficulty) 2123 $self->difficulty ($self->estimate_difficulty)
1883 unless $self->difficulty; 2124 unless $self->difficulty;
1884 Coro::cede; 2125 cf::cede_to_tick;
1885 2126
1886 unless ($self->{deny_activate}) { 2127 unless ($self->{deny_activate}) {
1887 $self->decay_objects; 2128 $self->decay_objects;
1888 $self->fix_auto_apply; 2129 $self->fix_auto_apply;
1889 $self->update_buttons; 2130 $self->update_buttons;
1890 Coro::cede; 2131 cf::cede_to_tick;
1891 $self->set_darkness_map;
1892 Coro::cede;
1893 $self->activate; 2132 $self->activate;
1894 } 2133 }
1895 2134
1896 $self->{last_save} = $cf::RUNTIME; 2135 $self->{last_save} = $cf::RUNTIME;
1897 $self->last_access ($cf::RUNTIME); 2136 $self->last_access ($cf::RUNTIME);
1898 2137
1899 $self->in_memory (cf::MAP_IN_MEMORY); 2138 $self->in_memory (cf::MAP_ACTIVE);
1900 } 2139 }
1901 2140
1902 $self->post_load; 2141 $self->post_load;
1903} 2142}
1904 2143
2144# customize the map for a given player, i.e.
2145# return the _real_ map. used by e.g. per-player
2146# maps to change the path to ~playername/mappath
1905sub customise_for { 2147sub customise_for {
1906 my ($self, $ob) = @_; 2148 my ($self, $ob) = @_;
1907 2149
1908 return find "~" . $ob->name . "/" . $self->{path} 2150 return find "~" . $ob->name . "/" . $self->{path}
1909 if $self->per_player; 2151 if $self->per_player;
1925 or next; 2167 or next;
1926 $neigh = find $neigh, $map 2168 $neigh = find $neigh, $map
1927 or next; 2169 or next;
1928 $neigh->load; 2170 $neigh->load;
1929 2171
2172 # now find the diagonal neighbours
1930 push @neigh, 2173 push @neigh,
1931 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2174 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1932 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2175 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1933 } 2176 }
1934 2177
1962 my ($path, $origin, $load) = @_; 2205 my ($path, $origin, $load) = @_;
1963 2206
1964 $path = normalise $path, $origin && $origin->{path}; 2207 $path = normalise $path, $origin && $origin->{path};
1965 2208
1966 if (my $map = $cf::MAP{$path}) { 2209 if (my $map = $cf::MAP{$path}) {
1967 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY; 2210 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
1968 } 2211 }
1969 2212
1970 $MAP_PREFETCH{$path} |= $load; 2213 $MAP_PREFETCH{$path} |= $load;
1971 2214
1972 $MAP_PREFETCHER ||= cf::async { 2215 $MAP_PREFETCHER ||= cf::async {
2216 $Coro::current->{desc} = "map prefetcher";
2217
1973 while (%MAP_PREFETCH) { 2218 while (%MAP_PREFETCH) {
1974 while (my ($k, $v) = each %MAP_PREFETCH) { 2219 while (my ($k, $v) = each %MAP_PREFETCH) {
1975 if (my $map = find $k) { 2220 if (my $map = find $k) {
1976 $map->load if $v; 2221 $map->load if $v;
1977 } 2222 }
1984 $MAP_PREFETCHER->prio (6); 2229 $MAP_PREFETCHER->prio (6);
1985 2230
1986 () 2231 ()
1987} 2232}
1988 2233
2234# common code, used by both ->save and ->swapout
1989sub save { 2235sub _save {
1990 my ($self) = @_; 2236 my ($self) = @_;
1991
1992 my $lock = cf::lock_acquire "map_data:" . $self->path;
1993 2237
1994 $self->{last_save} = $cf::RUNTIME; 2238 $self->{last_save} = $cf::RUNTIME;
1995 2239
1996 return unless $self->dirty; 2240 return unless $self->dirty;
1997 2241
2003 return if $self->{deny_save}; 2247 return if $self->{deny_save};
2004 2248
2005 local $self->{last_access} = $self->last_access;#d# 2249 local $self->{last_access} = $self->last_access;#d#
2006 2250
2007 cf::async { 2251 cf::async {
2252 $Coro::current->{desc} = "map player save";
2008 $_->contr->save for $self->players; 2253 $_->contr->save for $self->players;
2009 }; 2254 };
2255
2256 cf::get_slot 0.02;
2010 2257
2011 if ($uniq) { 2258 if ($uniq) {
2012 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2259 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
2013 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2260 $self->_save_objects ($uniq, cf::IO_UNIQUES);
2014 } else { 2261 } else {
2015 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2262 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2016 } 2263 }
2017} 2264}
2018 2265
2266sub save {
2267 my ($self) = @_;
2268
2269 my $lock = cf::lock_acquire "map_data:$self->{path}";
2270
2271 $self->_save;
2272}
2273
2019sub swap_out { 2274sub swap_out {
2020 my ($self) = @_; 2275 my ($self) = @_;
2021 2276
2022 # save first because save cedes
2023 $self->save;
2024
2025 my $lock = cf::lock_acquire "map_data:" . $self->path; 2277 my $lock = cf::lock_acquire "map_data:$self->{path}";
2026 2278
2279 return if $self->in_memory != cf::MAP_ACTIVE;
2280 return if $self->{deny_save};
2027 return if $self->players; 2281 return if $self->players;
2028 return if $self->in_memory != cf::MAP_IN_MEMORY;
2029 return if $self->{deny_save};
2030 2282
2283 # first deactivate the map and "unlink" it from the core
2284 $self->deactivate;
2285 $_->clear_links_to ($self) for values %cf::MAP;
2286 $self->in_memory (cf::MAP_SWAPPED);
2287
2288 # then atomically save
2289 $self->_save;
2290
2291 # then free the map
2031 $self->clear; 2292 $self->clear;
2032 $self->in_memory (cf::MAP_SWAPPED);
2033} 2293}
2034 2294
2035sub reset_at { 2295sub reset_at {
2036 my ($self) = @_; 2296 my ($self) = @_;
2037 2297
2055 2315
2056 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2316 my $lock = cf::lock_acquire "map_data:$self->{path}";
2057 2317
2058 return if $self->players; 2318 return if $self->players;
2059 2319
2060 warn "resetting map ", $self->path; 2320 warn "resetting map ", $self->path, "\n";
2061 2321
2062 $self->in_memory (cf::MAP_SWAPPED); 2322 $self->in_memory (cf::MAP_SWAPPED);
2063 2323
2064 # need to save uniques path 2324 # need to save uniques path
2065 unless ($self->{deny_save}) { 2325 unless ($self->{deny_save}) {
2069 if $uniq; 2329 if $uniq;
2070 } 2330 }
2071 2331
2072 delete $cf::MAP{$self->path}; 2332 delete $cf::MAP{$self->path};
2073 2333
2334 $self->deactivate;
2335 $_->clear_links_to ($self) for values %cf::MAP;
2074 $self->clear; 2336 $self->clear;
2075
2076 $_->clear_links_to ($self) for values %cf::MAP;
2077 2337
2078 $self->unlink_save; 2338 $self->unlink_save;
2079 $self->destroy; 2339 $self->destroy;
2080} 2340}
2081 2341
2082my $nuke_counter = "aaaa"; 2342my $nuke_counter = "aaaa";
2083 2343
2084sub nuke { 2344sub nuke {
2085 my ($self) = @_; 2345 my ($self) = @_;
2086 2346
2347 {
2348 my $lock = cf::lock_acquire "map_data:$self->{path}";
2349
2087 delete $cf::MAP{$self->path}; 2350 delete $cf::MAP{$self->path};
2088 2351
2089 $self->unlink_save; 2352 $self->unlink_save;
2090 2353
2091 bless $self, "cf::map"; 2354 bless $self, "cf::map::wrap";
2092 delete $self->{deny_reset}; 2355 delete $self->{deny_reset};
2093 $self->{deny_save} = 1; 2356 $self->{deny_save} = 1;
2094 $self->reset_timeout (1); 2357 $self->reset_timeout (1);
2095 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2358 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2096 2359
2097 $cf::MAP{$self->path} = $self; 2360 $cf::MAP{$self->path} = $self;
2361 }
2098 2362
2099 $self->reset; # polite request, might not happen 2363 $self->reset; # polite request, might not happen
2100} 2364}
2101 2365
2102=item $maps = cf::map::tmp_maps 2366=item $maps = cf::map::tmp_maps
2144 2408
2145sub unique_maps() { 2409sub unique_maps() {
2146 [ 2410 [
2147 map { 2411 map {
2148 utf8::decode $_; 2412 utf8::decode $_;
2149 /\.map$/ 2413 s/\.map$//; # TODO future compatibility hack
2414 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
2415 ? ()
2150 ? normalise $_ 2416 : normalise $_
2151 : ()
2152 } @{ aio_readdir $UNIQUEDIR or [] } 2417 } @{ aio_readdir $UNIQUEDIR or [] }
2153 ] 2418 ]
2154} 2419}
2155 2420
2156package cf; 2421=item cf::map::static_maps
2422
2423Returns an arrayref if paths of all static maps (all preinstalled F<.map>
2424file in the shared directory excluding F</styles> and F</editor>). May
2425block.
2426
2427=cut
2428
2429sub static_maps() {
2430 my @dirs = "";
2431 my @maps;
2432
2433 while (@dirs) {
2434 my $dir = shift @dirs;
2435
2436 next if $dir eq "/styles" || $dir eq "/editor";
2437
2438 my ($dirs, $files) = Coro::AIO::aio_scandir "$MAPDIR$dir", 2
2439 or return;
2440
2441 for (@$files) {
2442 s/\.map$// or next;
2443 utf8::decode $_;
2444 push @maps, "$dir/$_";
2445 }
2446
2447 push @dirs, map "$dir/$_", @$dirs;
2448 }
2449
2450 \@maps
2451}
2157 2452
2158=back 2453=back
2159 2454
2160=head3 cf::object 2455=head3 cf::object
2161 2456
2165 2460
2166=over 4 2461=over 4
2167 2462
2168=item $ob->inv_recursive 2463=item $ob->inv_recursive
2169 2464
2170Returns the inventory of the object _and_ their inventories, recursively. 2465Returns the inventory of the object I<and> their inventories, recursively,
2466but I<not> the object itself.
2171 2467
2172=cut 2468=cut
2173 2469
2174sub inv_recursive_; 2470sub inv_recursive_;
2175sub inv_recursive_ { 2471sub inv_recursive_ {
2178 2474
2179sub inv_recursive { 2475sub inv_recursive {
2180 inv_recursive_ inv $_[0] 2476 inv_recursive_ inv $_[0]
2181} 2477}
2182 2478
2479=item $ref = $ob->ref
2480
2481Creates and returns a persistent reference to an object that can be stored as a string.
2482
2483=item $ob = cf::object::deref ($refstring)
2484
2485returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2486even if the object actually exists. May block.
2487
2488=cut
2489
2490sub deref {
2491 my ($ref) = @_;
2492
2493 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2494 my ($uuid, $name) = ($1, $2);
2495 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2496 or return;
2497 $pl->ob->uuid eq $uuid
2498 or return;
2499
2500 $pl->ob
2501 } else {
2502 warn "$ref: cannot resolve object reference\n";
2503 undef
2504 }
2505}
2506
2183package cf; 2507package cf;
2184 2508
2185=back 2509=back
2186 2510
2187=head3 cf::object::player 2511=head3 cf::object::player
2193Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2517Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
2194can be C<undef>. Does the right thing when the player is currently in a 2518can be C<undef>. Does the right thing when the player is currently in a
2195dialogue with the given NPC character. 2519dialogue with the given NPC character.
2196 2520
2197=cut 2521=cut
2522
2523our $SAY_CHANNEL = {
2524 id => "say",
2525 title => "Map",
2526 reply => "say ",
2527 tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2528};
2529
2530our $CHAT_CHANNEL = {
2531 id => "chat",
2532 title => "Chat",
2533 reply => "chat ",
2534 tooltip => "Player chat and shouts, global to the server.",
2535};
2198 2536
2199# rough implementation of a future "reply" method that works 2537# rough implementation of a future "reply" method that works
2200# with dialog boxes. 2538# with dialog boxes.
2201#TODO: the first argument must go, split into a $npc->reply_to ( method 2539#TODO: the first argument must go, split into a $npc->reply_to ( method
2202sub cf::object::player::reply($$$;$) { 2540sub cf::object::player::reply($$$;$) {
2214 my $dialog = $pl->{npc_dialog}; 2552 my $dialog = $pl->{npc_dialog};
2215 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg)); 2553 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2216 2554
2217 } else { 2555 } else {
2218 $msg = $npc->name . " says: $msg" if $npc; 2556 $msg = $npc->name . " says: $msg" if $npc;
2219 $self->message ($msg, $flags); 2557 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2220 } 2558 }
2221 } 2559 }
2222} 2560}
2223 2561
2224=item $object->send_msg ($channel, $msg, $color, [extra...]) 2562=item $object->send_msg ($channel, $msg, $color, [extra...])
2249 2587
2250=item $player_object->enter_link 2588=item $player_object->enter_link
2251 2589
2252Freezes the player and moves him/her to a special map (C<{link}>). 2590Freezes the player and moves him/her to a special map (C<{link}>).
2253 2591
2254The player should be reasonably safe there for short amounts of time. You 2592The player should be reasonably safe there for short amounts of time (e.g.
2255I<MUST> call C<leave_link> as soon as possible, though. 2593for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2594though, as the player cannot control the character while it is on the link
2595map.
2256 2596
2257Will never block. 2597Will never block.
2258 2598
2259=item $player_object->leave_link ($map, $x, $y) 2599=item $player_object->leave_link ($map, $x, $y)
2260 2600
2280sub cf::object::player::enter_link { 2620sub cf::object::player::enter_link {
2281 my ($self) = @_; 2621 my ($self) = @_;
2282 2622
2283 $self->deactivate_recursive; 2623 $self->deactivate_recursive;
2284 2624
2625 ++$self->{_link_recursion};
2626
2285 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2627 return if UNIVERSAL::isa $self->map, "ext::map_link";
2286 2628
2287 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2629 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2288 if $self->map && $self->map->{path} ne "{link}"; 2630 if $self->map && $self->map->{path} ne "{link}";
2289 2631
2290 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2632 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2291} 2633}
2292 2634
2293sub cf::object::player::leave_link { 2635sub cf::object::player::leave_link {
2294 my ($self, $map, $x, $y) = @_; 2636 my ($self, $map, $x, $y) = @_;
2295 2637
2312 ($x, $y) = (-1, -1) 2654 ($x, $y) = (-1, -1)
2313 unless (defined $x) && (defined $y); 2655 unless (defined $x) && (defined $y);
2314 2656
2315 # use -1 or undef as default coordinates, not 0, 0 2657 # use -1 or undef as default coordinates, not 0, 0
2316 ($x, $y) = ($map->enter_x, $map->enter_y) 2658 ($x, $y) = ($map->enter_x, $map->enter_y)
2317 if $x <=0 && $y <= 0; 2659 if $x <= 0 && $y <= 0;
2318 2660
2319 $map->load; 2661 $map->load;
2320 $map->load_neighbours; 2662 $map->load_neighbours;
2321 2663
2322 return unless $self->contr->active; 2664 return unless $self->contr->active;
2323 $self->activate_recursive;
2324 2665
2325 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2666 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2326 $self->enter_map ($map, $x, $y); 2667 if ($self->enter_map ($map, $x, $y)) {
2327} 2668 # entering was successful
2669 delete $self->{_link_recursion};
2670 # only activate afterwards, to support waiting in hooks
2671 $self->activate_recursive;
2672 }
2328 2673
2674}
2675
2329=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2676=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2330 2677
2331Moves the player to the given map-path and coordinates by first freezing 2678Moves the player to the given map-path and coordinates by first freezing
2332her, loading and preparing them map, calling the provided $check callback 2679her, loading and preparing them map, calling the provided $check callback
2333that has to return the map if sucecssful, and then unfreezes the player on 2680that has to return the map if sucecssful, and then unfreezes the player on
2334the new (success) or old (failed) map position. In either case, $done will 2681the new (success) or old (failed) map position. In either case, $done will
2335be called at the end of this process. 2682be called at the end of this process.
2336 2683
2684Note that $check will be called with a potentially non-loaded map, so if
2685it needs a loaded map it has to call C<< ->load >>.
2686
2337=cut 2687=cut
2338 2688
2339our $GOTOGEN; 2689our $GOTOGEN;
2340 2690
2341sub cf::object::player::goto { 2691sub cf::object::player::goto {
2342 my ($self, $path, $x, $y, $check, $done) = @_; 2692 my ($self, $path, $x, $y, $check, $done) = @_;
2343 2693
2694 if ($self->{_link_recursion} >= $MAX_LINKS) {
2695 warn "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2696 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2697 ($path, $x, $y) = @$EMERGENCY_POSITION;
2698 }
2699
2344 # do generation counting so two concurrent goto's will be executed in-order 2700 # do generation counting so two concurrent goto's will be executed in-order
2345 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2701 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2346 2702
2347 $self->enter_link; 2703 $self->enter_link;
2348 2704
2349 (async { 2705 (async {
2706 $Coro::current->{desc} = "player::goto $path $x $y";
2707
2708 # *tag paths override both path and x|y
2709 if ($path =~ /^\*(.*)$/) {
2710 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2711 my $ob = $obs[rand @obs];
2712
2713 # see if we actually can go there
2714 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2715 $ob = $obs[rand @obs];
2716 } else {
2717 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2718 }
2719 # else put us there anyways for now #d#
2720
2721 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2722 } else {
2723 ($path, $x, $y) = (undef, undef, undef);
2724 }
2725 }
2726
2350 my $map = eval { 2727 my $map = eval {
2351 my $map = cf::map::find $path; 2728 my $map = defined $path ? cf::map::find $path : undef;
2352 2729
2353 if ($map) { 2730 if ($map) {
2354 $map = $map->customise_for ($self); 2731 $map = $map->customise_for ($self);
2355 $map = $check->($map) if $check && $map; 2732 $map = $check->($map, $x, $y, $self) if $check && $map;
2356 } else { 2733 } else {
2357 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2734 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2358 } 2735 }
2359 2736
2360 $map 2737 $map
2361 }; 2738 };
2362 2739
2368 if ($gen == $self->{_goto_generation}) { 2745 if ($gen == $self->{_goto_generation}) {
2369 delete $self->{_goto_generation}; 2746 delete $self->{_goto_generation};
2370 $self->leave_link ($map, $x, $y); 2747 $self->leave_link ($map, $x, $y);
2371 } 2748 }
2372 2749
2373 $done->() if $done; 2750 $done->($self) if $done;
2374 })->prio (1); 2751 })->prio (1);
2375} 2752}
2376 2753
2377=item $player_object->enter_exit ($exit_object) 2754=item $player_object->enter_exit ($exit_object)
2378 2755
2398} 2775}
2399 2776
2400sub prepare_random_map { 2777sub prepare_random_map {
2401 my ($exit) = @_; 2778 my ($exit) = @_;
2402 2779
2403 my $guard = cf::lock_acquire "exit_prepare:$exit";
2404
2405 # all this does is basically replace the /! path by 2780 # all this does is basically replace the /! path by
2406 # a new random map path (?random/...) with a seed 2781 # a new random map path (?random/...) with a seed
2407 # that depends on the exit object 2782 # that depends on the exit object
2408 2783
2409 my $rmp = parse_random_map_params $exit->msg; 2784 my $rmp = parse_random_map_params $exit->msg;
2411 if ($exit->map) { 2786 if ($exit->map) {
2412 $rmp->{region} = $exit->region->name; 2787 $rmp->{region} = $exit->region->name;
2413 $rmp->{origin_map} = $exit->map->path; 2788 $rmp->{origin_map} = $exit->map->path;
2414 $rmp->{origin_x} = $exit->x; 2789 $rmp->{origin_x} = $exit->x;
2415 $rmp->{origin_y} = $exit->y; 2790 $rmp->{origin_y} = $exit->y;
2791
2792 $exit->map->touch;
2416 } 2793 }
2417 2794
2418 $rmp->{random_seed} ||= $exit->random_seed; 2795 $rmp->{random_seed} ||= $exit->random_seed;
2419 2796
2420 my $data = cf::to_json $rmp; 2797 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
2421 my $md5 = Digest::MD5::md5_hex $data; 2798 my $md5 = Digest::MD5::md5_hex $data;
2422 my $meta = "$RANDOMDIR/$md5.meta"; 2799 my $meta = "$RANDOMDIR/$md5.meta";
2423 2800
2424 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2801 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2425 aio_write $fh, 0, (length $data), $data, 0; 2802 aio_write $fh, 0, (length $data), $data, 0;
2426 undef $fh; 2803 undef $fh;
2427 aio_rename "$meta~", $meta; 2804 aio_rename "$meta~", $meta;
2428 2805
2806 my $slaying = "?random/$md5";
2807
2808 if ($exit->valid) {
2429 $exit->slaying ("?random/$md5"); 2809 $exit->slaying ("?random/$md5");
2430 $exit->msg (undef); 2810 $exit->msg (undef);
2811 }
2431 } 2812 }
2432} 2813}
2433 2814
2434sub cf::object::player::enter_exit { 2815sub cf::object::player::enter_exit {
2435 my ($self, $exit) = @_; 2816 my ($self, $exit) = @_;
2436 2817
2437 return unless $self->type == cf::PLAYER; 2818 return unless $self->type == cf::PLAYER;
2438 2819
2439 if ($exit->slaying eq "/!") {
2440 #TODO: this should de-fi-ni-te-ly not be a sync-job
2441 # the problem is that $exit might not survive long enough
2442 # so it needs to be done right now, right here
2443 cf::sync_job { prepare_random_map $exit };
2444 }
2445
2446 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2447 my $hp = $exit->stats->hp;
2448 my $sp = $exit->stats->sp;
2449
2450 $self->enter_link; 2820 $self->enter_link;
2451 2821
2452 # if exit is damned, update players death & WoR home-position
2453 $self->contr->savebed ($slaying, $hp, $sp)
2454 if $exit->flag (FLAG_DAMNED);
2455
2456 (async { 2822 (async {
2457 $self->deactivate_recursive; # just to be sure 2823 $Coro::current->{desc} = "enter_exit";
2824
2458 unless (eval { 2825 unless (eval {
2826 $self->deactivate_recursive; # just to be sure
2827
2828 # random map handling
2829 {
2830 my $guard = cf::lock_acquire "exit_prepare:$exit";
2831
2832 prepare_random_map $exit
2833 if $exit->slaying eq "/!";
2834 }
2835
2836 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2837 my $x = $exit->stats->hp;
2838 my $y = $exit->stats->sp;
2839
2459 $self->goto ($slaying, $hp, $sp); 2840 $self->goto ($map, $x, $y);
2460 2841
2842 # if exit is damned, update players death & WoR home-position
2843 $self->contr->savebed ($map, $x, $y)
2844 if $exit->flag (cf::FLAG_DAMNED);
2845
2461 1; 2846 1
2462 }) { 2847 }) {
2463 $self->message ("Something went wrong deep within the crossfire server. " 2848 $self->message ("Something went wrong deep within the deliantra server. "
2464 . "I'll try to bring you back to the map you were before. " 2849 . "I'll try to bring you back to the map you were before. "
2465 . "Please report this to the dungeon master!", 2850 . "Please report this to the dungeon master!",
2466 cf::NDI_UNIQUE | cf::NDI_RED); 2851 cf::NDI_UNIQUE | cf::NDI_RED);
2467 2852
2468 warn "ERROR in enter_exit: $@"; 2853 warn "ERROR in enter_exit: $@";
2485sub cf::client::send_drawinfo { 2870sub cf::client::send_drawinfo {
2486 my ($self, $text, $flags) = @_; 2871 my ($self, $text, $flags) = @_;
2487 2872
2488 utf8::encode $text; 2873 utf8::encode $text;
2489 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2874 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2875}
2876
2877=item $client->send_big_packet ($pkt)
2878
2879Like C<send_packet>, but tries to compress large packets, and fragments
2880them as required.
2881
2882=cut
2883
2884our $MAXFRAGSIZE = cf::MAXSOCKBUF - 64;
2885
2886sub cf::client::send_big_packet {
2887 my ($self, $pkt) = @_;
2888
2889 # try lzf for large packets
2890 $pkt = "lzf " . Compress::LZF::compress $pkt
2891 if 1024 <= length $pkt and $self->{can_lzf};
2892
2893 # split very large packets
2894 if ($MAXFRAGSIZE < length $pkt and $self->{can_lzf}) {
2895 $self->send_packet ("frag $_") for unpack "(a$MAXFRAGSIZE)*", $pkt;
2896 $pkt = "frag";
2897 }
2898
2899 $self->send_packet ($pkt);
2490} 2900}
2491 2901
2492=item $client->send_msg ($channel, $msg, $color, [extra...]) 2902=item $client->send_msg ($channel, $msg, $color, [extra...])
2493 2903
2494Send a drawinfo or msg packet to the client, formatting the msg for the 2904Send a drawinfo or msg packet to the client, formatting the msg for the
2496the message, with C<log> being the default. If C<$color> is negative, suppress 2906the message, with C<log> being the default. If C<$color> is negative, suppress
2497the message unless the client supports the msg packet. 2907the message unless the client supports the msg packet.
2498 2908
2499=cut 2909=cut
2500 2910
2911# non-persistent channels (usually the info channel)
2912our %CHANNEL = (
2913 "c/motd" => {
2914 id => "infobox",
2915 title => "MOTD",
2916 reply => undef,
2917 tooltip => "The message of the day",
2918 },
2919 "c/identify" => {
2920 id => "infobox",
2921 title => "Identify",
2922 reply => undef,
2923 tooltip => "Items recently identified",
2924 },
2925 "c/examine" => {
2926 id => "infobox",
2927 title => "Examine",
2928 reply => undef,
2929 tooltip => "Signs and other items you examined",
2930 },
2931 "c/shopinfo" => {
2932 id => "infobox",
2933 title => "Shop Info",
2934 reply => undef,
2935 tooltip => "What your bargaining skill tells you about the shop",
2936 },
2937 "c/book" => {
2938 id => "infobox",
2939 title => "Book",
2940 reply => undef,
2941 tooltip => "The contents of a note or book",
2942 },
2943 "c/lookat" => {
2944 id => "infobox",
2945 title => "Look",
2946 reply => undef,
2947 tooltip => "What you saw there",
2948 },
2949 "c/who" => {
2950 id => "infobox",
2951 title => "Players",
2952 reply => undef,
2953 tooltip => "Shows players who are currently online",
2954 },
2955 "c/body" => {
2956 id => "infobox",
2957 title => "Body Parts",
2958 reply => undef,
2959 tooltip => "Shows which body parts you posess and are available",
2960 },
2961 "c/statistics" => {
2962 id => "infobox",
2963 title => "Statistics",
2964 reply => undef,
2965 tooltip => "Shows your primary statistics",
2966 },
2967 "c/skills" => {
2968 id => "infobox",
2969 title => "Skills",
2970 reply => undef,
2971 tooltip => "Shows your experience per skill and item power",
2972 },
2973 "c/shopitems" => {
2974 id => "infobox",
2975 title => "Shop Items",
2976 reply => undef,
2977 tooltip => "Shows the items currently for sale in this shop",
2978 },
2979 "c/resistances" => {
2980 id => "infobox",
2981 title => "Resistances",
2982 reply => undef,
2983 tooltip => "Shows your resistances",
2984 },
2985 "c/pets" => {
2986 id => "infobox",
2987 title => "Pets",
2988 reply => undef,
2989 tooltip => "Shows information abotu your pets/a specific pet",
2990 },
2991 "c/perceiveself" => {
2992 id => "infobox",
2993 title => "Perceive Self",
2994 reply => undef,
2995 tooltip => "You gained detailed knowledge about yourself",
2996 },
2997 "c/uptime" => {
2998 id => "infobox",
2999 title => "Uptime",
3000 reply => undef,
3001 tooltip => "How long the server has been running since last restart",
3002 },
3003 "c/mapinfo" => {
3004 id => "infobox",
3005 title => "Map Info",
3006 reply => undef,
3007 tooltip => "Information related to the maps",
3008 },
3009 "c/party" => {
3010 id => "party",
3011 title => "Party",
3012 reply => "gsay ",
3013 tooltip => "Messages and chat related to your party",
3014 },
3015 "c/death" => {
3016 id => "death",
3017 title => "Death",
3018 reply => undef,
3019 tooltip => "Reason for and more info about your most recent death",
3020 },
3021 "c/say" => $SAY_CHANNEL,
3022 "c/chat" => $CHAT_CHANNEL,
3023);
3024
2501sub cf::client::send_msg { 3025sub cf::client::send_msg {
2502 my ($self, $channel, $msg, $color, @extra) = @_; 3026 my ($self, $channel, $msg, $color, @extra) = @_;
2503 3027
2504 $msg = $self->pl->expand_cfpod ($msg); 3028 $msg = $self->pl->expand_cfpod ($msg)
3029 unless $color & cf::NDI_VERBATIM;
2505 3030
2506 $color &= cf::NDI_CLIENT_MASK; # just in case... 3031 $color &= cf::NDI_CLIENT_MASK; # just in case...
2507 3032
3033 # check predefined channels, for the benefit of C
3034 if ($CHANNEL{$channel}) {
3035 $channel = $CHANNEL{$channel};
3036
3037 $self->ext_msg (channel_info => $channel);
3038 $channel = $channel->{id};
3039
2508 if (ref $channel) { 3040 } elsif (ref $channel) {
2509 # send meta info to client, if not yet sent 3041 # send meta info to client, if not yet sent
2510 unless (exists $self->{channel}{$channel->{id}}) { 3042 unless (exists $self->{channel}{$channel->{id}}) {
2511 $self->{channel}{$channel->{id}} = $channel; 3043 $self->{channel}{$channel->{id}} = $channel;
2512 $self->ext_msg (channel_info => $channel); 3044 $self->ext_msg (channel_info => $channel);
2513 } 3045 }
2515 $channel = $channel->{id}; 3047 $channel = $channel->{id};
2516 } 3048 }
2517 3049
2518 return unless @extra || length $msg; 3050 return unless @extra || length $msg;
2519 3051
2520 if ($self->can_msg) {
2521 # default colour, mask it out 3052 # default colour, mask it out
2522 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF) 3053 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2523 if $color & cf::NDI_DEF; 3054 if $color & cf::NDI_DEF;
2524 3055
2525 $self->send_packet ("msg " . $self->{json_coder}->encode ( 3056 my $pkt = "msg "
3057 . $self->{json_coder}->encode (
2526 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra])); 3058 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2527 } else { 3059 );
2528 if ($color >= 0) {
2529 # replace some tags by gcfclient-compatible ones
2530 for ($msg) {
2531 1 while
2532 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2533 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2534 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2535 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2536 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2537 }
2538 3060
2539 $color &= cf::NDI_COLOR_MASK; 3061 $self->send_big_packet ($pkt);
2540
2541 utf8::encode $msg;
2542
2543 if (0 && $msg =~ /\[/) {
2544 # COMMAND/INFO
2545 $self->send_packet ("drawextinfo $color 10 8 $msg")
2546 } else {
2547 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2548 $self->send_packet ("drawinfo $color $msg")
2549 }
2550 }
2551 }
2552} 3062}
2553 3063
2554=item $client->ext_msg ($type, @msg) 3064=item $client->ext_msg ($type, @msg)
2555 3065
2556Sends an ext event to the client. 3066Sends an ext event to the client.
2559 3069
2560sub cf::client::ext_msg($$@) { 3070sub cf::client::ext_msg($$@) {
2561 my ($self, $type, @msg) = @_; 3071 my ($self, $type, @msg) = @_;
2562 3072
2563 if ($self->extcmd == 2) { 3073 if ($self->extcmd == 2) {
2564 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg])); 3074 $self->send_big_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2565 } elsif ($self->extcmd == 1) { # TODO: remove 3075 } elsif ($self->extcmd == 1) { # TODO: remove
2566 push @msg, msgtype => "event_$type"; 3076 push @msg, msgtype => "event_$type";
2567 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3077 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2568 } 3078 }
2569} 3079}
2570 3080
2571=item $client->ext_reply ($msgid, @msg) 3081=item $client->ext_reply ($msgid, @msg)
2572 3082
2576 3086
2577sub cf::client::ext_reply($$@) { 3087sub cf::client::ext_reply($$@) {
2578 my ($self, $id, @msg) = @_; 3088 my ($self, $id, @msg) = @_;
2579 3089
2580 if ($self->extcmd == 2) { 3090 if ($self->extcmd == 2) {
2581 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg])); 3091 $self->send_big_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2582 } elsif ($self->extcmd == 1) { 3092 } elsif ($self->extcmd == 1) {
2583 #TODO: version 1, remove 3093 #TODO: version 1, remove
2584 unshift @msg, msgtype => "reply", msgid => $id; 3094 unshift @msg, msgtype => "reply", msgid => $id;
2585 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg})); 3095 $self->send_big_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2586 } 3096 }
2587} 3097}
2588 3098
2589=item $success = $client->query ($flags, "text", \&cb) 3099=item $success = $client->query ($flags, "text", \&cb)
2590 3100
2691 3201
2692 $coro 3202 $coro
2693} 3203}
2694 3204
2695cf::client->attach ( 3205cf::client->attach (
2696 on_destroy => sub { 3206 on_client_destroy => sub {
2697 my ($ns) = @_; 3207 my ($ns) = @_;
2698 3208
2699 $_->cancel for values %{ (delete $ns->{_coro}) || {} }; 3209 $_->cancel for values %{ (delete $ns->{_coro}) || {} };
2700 }, 3210 },
2701); 3211);
2717our $safe_hole = new Safe::Hole; 3227our $safe_hole = new Safe::Hole;
2718 3228
2719$SIG{FPE} = 'IGNORE'; 3229$SIG{FPE} = 'IGNORE';
2720 3230
2721$safe->permit_only (Opcode::opset qw( 3231$safe->permit_only (Opcode::opset qw(
2722 :base_core :base_mem :base_orig :base_math 3232 :base_core :base_mem :base_orig :base_math :base_loop
2723 grepstart grepwhile mapstart mapwhile 3233 grepstart grepwhile mapstart mapwhile
2724 sort time 3234 sort time
2725)); 3235));
2726 3236
2727# here we export the classes and methods available to script code 3237# here we export the classes and methods available to script code
2729=pod 3239=pod
2730 3240
2731The following functions and methods are available within a safe environment: 3241The following functions and methods are available within a safe environment:
2732 3242
2733 cf::object 3243 cf::object
2734 contr pay_amount pay_player map x y force_find force_add 3244 contr pay_amount pay_player map x y force_find force_add destroy
2735 insert remove name archname title slaying race decrease_ob_nr 3245 insert remove name archname title slaying race decrease split
3246 value
2736 3247
2737 cf::object::player 3248 cf::object::player
2738 player 3249 player
2739 3250
2740 cf::player 3251 cf::player
2745 3256
2746=cut 3257=cut
2747 3258
2748for ( 3259for (
2749 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3260 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2750 insert remove inv name archname title slaying race 3261 insert remove inv nrof name archname title slaying race
2751 decrease_ob_nr)], 3262 decrease split destroy change_exp value msg lore send_msg)],
2752 ["cf::object::player" => qw(player)], 3263 ["cf::object::player" => qw(player)],
2753 ["cf::player" => qw(peaceful)], 3264 ["cf::player" => qw(peaceful send_msg)],
2754 ["cf::map" => qw(trigger)], 3265 ["cf::map" => qw(trigger)],
2755) { 3266) {
2756 no strict 'refs'; 3267 no strict 'refs';
2757 my ($pkg, @funs) = @$_; 3268 my ($pkg, @funs) = @$_;
2758 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3269 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
2776 3287
2777 my $qcode = $code; 3288 my $qcode = $code;
2778 $qcode =~ s/"/‟/g; # not allowed in #line filenames 3289 $qcode =~ s/"/‟/g; # not allowed in #line filenames
2779 $qcode =~ s/\n/\\n/g; 3290 $qcode =~ s/\n/\\n/g;
2780 3291
3292 %vars = (_dummy => 0) unless %vars;
3293
3294 my @res;
2781 local $_; 3295 local $_;
2782 local @safe::cf::_safe_eval_args = values %vars;
2783 3296
2784 my $eval = 3297 my $eval =
2785 "do {\n" 3298 "do {\n"
2786 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n" 3299 . "my (" . (join ",", map "\$$_", keys %vars) . ") = \@cf::_safe_eval_args;\n"
2787 . "#line 0 \"{$qcode}\"\n" 3300 . "#line 0 \"{$qcode}\"\n"
2788 . $code 3301 . $code
2789 . "\n}" 3302 . "\n}"
2790 ; 3303 ;
2791 3304
3305 if ($CFG{safe_eval}) {
2792 sub_generation_inc; 3306 sub_generation_inc;
3307 local @safe::cf::_safe_eval_args = values %vars;
2793 my @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval); 3308 @res = wantarray ? $safe->reval ($eval) : scalar $safe->reval ($eval);
2794 sub_generation_inc; 3309 sub_generation_inc;
3310 } else {
3311 local @cf::_safe_eval_args = values %vars;
3312 @res = wantarray ? eval eval : scalar eval $eval;
3313 }
2795 3314
2796 if ($@) { 3315 if ($@) {
2797 warn "$@"; 3316 warn "$@";
2798 warn "while executing safe code '$code'\n"; 3317 warn "while executing safe code '$code'\n";
2799 warn "with arguments " . (join " ", %vars) . "\n"; 3318 warn "with arguments " . (join " ", %vars) . "\n";
2818=cut 3337=cut
2819 3338
2820sub register_script_function { 3339sub register_script_function {
2821 my ($fun, $cb) = @_; 3340 my ($fun, $cb) = @_;
2822 3341
2823 no strict 'refs'; 3342 $fun = "safe::$fun" if $CFG{safe_eval};
2824 *{"safe::$fun"} = $safe_hole->wrap ($cb); 3343 *$fun = $safe_hole->wrap ($cb);
2825} 3344}
2826 3345
2827=back 3346=back
2828 3347
2829=cut 3348=cut
2832# the server's init and main functions 3351# the server's init and main functions
2833 3352
2834sub load_facedata($) { 3353sub load_facedata($) {
2835 my ($path) = @_; 3354 my ($path) = @_;
2836 3355
3356 # HACK to clear player env face cache, we need some signal framework
3357 # for this (global event?)
3358 %ext::player_env::MUSIC_FACE_CACHE = ();
3359
2837 my $enc = JSON::XS->new->utf8->canonical; 3360 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2838 3361
2839 warn "loading facedata from $path\n"; 3362 warn "loading facedata from $path\n";
2840 3363
2841 my $facedata; 3364 my $facedata;
2842 0 < aio_load $path, $facedata 3365 0 < aio_load $path, $facedata
2846 3369
2847 $facedata->{version} == 2 3370 $facedata->{version} == 2
2848 or cf::cleanup "$path: version mismatch, cannot proceed."; 3371 or cf::cleanup "$path: version mismatch, cannot proceed.";
2849 3372
2850 # patch in the exptable 3373 # patch in the exptable
3374 my $exp_table = $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]);
2851 $facedata->{resource}{"res/exp_table"} = { 3375 $facedata->{resource}{"res/exp_table"} = {
2852 type => FT_RSRC, 3376 type => FT_RSRC,
2853 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]), 3377 data => $exp_table,
3378 hash => (Digest::MD5::md5 $exp_table),
2854 }; 3379 };
2855 cf::cede_to_tick; 3380 cf::cede_to_tick;
2856 3381
2857 { 3382 {
2858 my $faces = $facedata->{faceinfo}; 3383 my $faces = $facedata->{faceinfo};
2859 3384
2860 while (my ($face, $info) = each %$faces) { 3385 while (my ($face, $info) = each %$faces) {
2861 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3386 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3387
2862 cf::face::set_visibility $idx, $info->{visibility}; 3388 cf::face::set_visibility $idx, $info->{visibility};
2863 cf::face::set_magicmap $idx, $info->{magicmap}; 3389 cf::face::set_magicmap $idx, $info->{magicmap};
2864 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3390 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
2865 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3391 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
2866 3392
2867 cf::cede_to_tick; 3393 cf::cede_to_tick;
2868 } 3394 }
2869 3395
2870 while (my ($face, $info) = each %$faces) { 3396 while (my ($face, $info) = each %$faces) {
2871 next unless $info->{smooth}; 3397 next unless $info->{smooth};
3398
2872 my $idx = cf::face::find $face 3399 my $idx = cf::face::find $face
2873 or next; 3400 or next;
3401
2874 if (my $smooth = cf::face::find $info->{smooth}) { 3402 if (my $smooth = cf::face::find $info->{smooth}) {
2875 cf::face::set_smooth $idx, $smooth; 3403 cf::face::set_smooth $idx, $smooth;
2876 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3404 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2877 } else { 3405 } else {
2878 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3406 warn "smooth face '$info->{smooth}' not found for face '$face'";
2892 3420
2893 cf::anim::invalidate_all; # d'oh 3421 cf::anim::invalidate_all; # d'oh
2894 } 3422 }
2895 3423
2896 { 3424 {
2897 # TODO: for gcfclient pleasure, we should give resources
2898 # that gcfclient doesn't grok a >10000 face index.
2899 my $res = $facedata->{resource}; 3425 my $res = $facedata->{resource};
2900 3426
2901 my $soundconf = delete $res->{"res/sound.conf"};
2902
2903 while (my ($name, $info) = each %$res) { 3427 while (my ($name, $info) = each %$res) {
3428 if (defined $info->{type}) {
2904 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3429 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2905 my $data;
2906 3430
2907 if ($info->{type} & 1) { 3431 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
2908 # prepend meta info 3432 cf::face::set_type $idx, $info->{type};
2909
2910 my $meta = $enc->encode ({
2911 name => $name,
2912 %{ $info->{meta} || {} },
2913 });
2914
2915 $data = pack "(w/a*)*", $meta, $info->{data};
2916 } else { 3433 } else {
2917 $data = $info->{data}; 3434 $RESOURCE{$name} = $info;
2918 } 3435 }
2919 3436
2920 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2921 cf::face::set_type $idx, $info->{type};
2922
2923 cf::cede_to_tick; 3437 cf::cede_to_tick;
2924 } 3438 }
2925
2926 if ($soundconf) {
2927 $soundconf = $enc->decode (delete $soundconf->{data});
2928
2929 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2930 my $sound = $soundconf->{compat}[$_]
2931 or next;
2932
2933 my $face = cf::face::find "sound/$sound->[1]";
2934 cf::sound::set $sound->[0] => $face;
2935 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2936 }
2937
2938 while (my ($k, $v) = each %{$soundconf->{event}}) {
2939 my $face = cf::face::find "sound/$v";
2940 cf::sound::set $k => $face;
2941 }
2942 }
2943 } 3439 }
3440
3441 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2944 3442
2945 1 3443 1
2946} 3444}
3445
3446cf::global->attach (on_resource_update => sub {
3447 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3448 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3449
3450 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3451 my $sound = $soundconf->{compat}[$_]
3452 or next;
3453
3454 my $face = cf::face::find "sound/$sound->[1]";
3455 cf::sound::set $sound->[0] => $face;
3456 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3457 }
3458
3459 while (my ($k, $v) = each %{$soundconf->{event}}) {
3460 my $face = cf::face::find "sound/$v";
3461 cf::sound::set $k => $face;
3462 }
3463 }
3464});
2947 3465
2948register_exticmd fx_want => sub { 3466register_exticmd fx_want => sub {
2949 my ($ns, $want) = @_; 3467 my ($ns, $want) = @_;
2950 3468
2951 while (my ($k, $v) = each %$want) { 3469 while (my ($k, $v) = each %$want) {
2952 $ns->fx_want ($k, $v); 3470 $ns->fx_want ($k, $v);
2953 } 3471 }
2954}; 3472};
2955 3473
3474sub load_resource_file($) {
3475 my $guard = lock_acquire "load_resource_file";
3476
3477 my $status = load_resource_file_ $_[0];
3478 get_slot 0.1, 100;
3479 cf::arch::commit_load;
3480
3481 $status
3482}
3483
2956sub reload_regions { 3484sub reload_regions {
3485 # HACK to clear player env face cache, we need some signal framework
3486 # for this (global event?)
3487 %ext::player_env::MUSIC_FACE_CACHE = ();
3488
2957 load_resource_file "$MAPDIR/regions" 3489 load_resource_file "$MAPDIR/regions"
2958 or die "unable to load regions file\n"; 3490 or die "unable to load regions file\n";
2959 3491
2960 for (cf::region::list) { 3492 for (cf::region::list) {
2961 $_->{match} = qr/$_->{match}/ 3493 $_->{match} = qr/$_->{match}/
2969} 3501}
2970 3502
2971sub reload_archetypes { 3503sub reload_archetypes {
2972 load_resource_file "$DATADIR/archetypes" 3504 load_resource_file "$DATADIR/archetypes"
2973 or die "unable to load archetypes\n"; 3505 or die "unable to load archetypes\n";
2974 #d# NEED to laod twice to resolve forward references
2975 # this really needs to be done in an extra post-pass
2976 # (which needs to be synchronous, so solve it differently)
2977 load_resource_file "$DATADIR/archetypes"
2978 or die "unable to load archetypes\n";
2979} 3506}
2980 3507
2981sub reload_treasures { 3508sub reload_treasures {
2982 load_resource_file "$DATADIR/treasures" 3509 load_resource_file "$DATADIR/treasures"
2983 or die "unable to load treasurelists\n"; 3510 or die "unable to load treasurelists\n";
2984} 3511}
2985 3512
2986sub reload_resources { 3513sub reload_resources {
2987 warn "reloading resource files...\n"; 3514 warn "reloading resource files...\n";
2988 3515
3516 reload_facedata;
3517 reload_archetypes;
2989 reload_regions; 3518 reload_regions;
2990 reload_facedata;
2991 #reload_archetypes;#d#
2992 reload_archetypes;
2993 reload_treasures; 3519 reload_treasures;
2994 3520
2995 warn "finished reloading resource files\n"; 3521 warn "finished reloading resource files\n";
2996} 3522}
2997 3523
2998sub init { 3524sub reload_config {
2999 reload_resources; 3525 warn "reloading config file...\n";
3000}
3001 3526
3002sub cfg_load {
3003 open my $fh, "<:utf8", "$CONFDIR/config" 3527 open my $fh, "<:utf8", "$CONFDIR/config"
3004 or return; 3528 or return;
3005 3529
3006 local $/; 3530 local $/;
3007 *CFG = YAML::Syck::Load <$fh>; 3531 *CFG = YAML::XS::Load scalar <$fh>;
3008 3532
3009 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3533 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3010 3534
3011 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3535 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3012 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3536 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3013 3537
3014 if (exists $CFG{mlockall}) { 3538 if (exists $CFG{mlockall}) {
3016 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3540 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3017 and die "WARNING: m(un)lockall failed: $!\n"; 3541 and die "WARNING: m(un)lockall failed: $!\n";
3018 }; 3542 };
3019 warn $@ if $@; 3543 warn $@ if $@;
3020 } 3544 }
3545
3546 warn "finished reloading resource files\n";
3547}
3548
3549sub pidfile() {
3550 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3551 or die "$PIDFILE: $!";
3552 flock $fh, &Fcntl::LOCK_EX
3553 or die "$PIDFILE: flock: $!";
3554 $fh
3555}
3556
3557# make sure only one server instance is running at any one time
3558sub atomic {
3559 my $fh = pidfile;
3560
3561 my $pid = <$fh>;
3562 kill 9, $pid if $pid > 0;
3563
3564 seek $fh, 0, 0;
3565 print $fh $$;
3566}
3567
3568sub main_loop {
3569 warn "EV::loop starting\n";
3570 if (1) {
3571 EV::loop;
3572 }
3573 warn "EV::loop returned\n";
3574 goto &main_loop unless $REALLY_UNLOOP;
3021} 3575}
3022 3576
3023sub main { 3577sub main {
3578 cf::init_globals; # initialise logging
3579
3580 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3581 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3582 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3583 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3584
3585 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3586
3024 # we must not ever block the main coroutine 3587 # we must not ever block the main coroutine
3025 local $Coro::idle = sub { 3588 local $Coro::idle = sub {
3026 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3589 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3027 (async { 3590 (async {
3028 Event::one_event; 3591 $Coro::current->{desc} = "IDLE BUG HANDLER";
3592 EV::loop EV::LOOP_ONESHOT;
3029 })->prio (Coro::PRIO_MAX); 3593 })->prio (Coro::PRIO_MAX);
3030 }; 3594 };
3031 3595
3032 cfg_load; 3596 evthread_start IO::AIO::poll_fileno;
3597
3598 cf::sync_job {
3599 cf::init_experience;
3600 cf::init_anim;
3601 cf::init_attackmess;
3602 cf::init_dynamic;
3603
3604 cf::load_settings;
3605 cf::load_materials;
3606
3607 reload_resources;
3608 reload_config;
3033 db_init; 3609 db_init;
3610
3611 cf::init_uuid;
3612 cf::init_signals;
3613 cf::init_skills;
3614
3615 cf::init_beforeplay;
3616
3617 atomic;
3618
3034 load_extensions; 3619 load_extensions;
3035 3620
3036 $TICK_WATCHER->start; 3621 utime time, time, $RUNTIMEFILE;
3037 Event::loop; 3622
3623 # no (long-running) fork's whatsoever before this point(!)
3624 use POSIX ();
3625 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3626
3627 (pop @POST_INIT)->(0) while @POST_INIT;
3628 };
3629
3630 cf::object::thawer::errors_are_fatal 0;
3631 warn "parse errors in files are no longer fatal from this point on.\n";
3632
3633 main_loop;
3038} 3634}
3039 3635
3040############################################################################# 3636#############################################################################
3041# initialisation and cleanup 3637# initialisation and cleanup
3042 3638
3043# install some emergency cleanup handlers 3639# install some emergency cleanup handlers
3044BEGIN { 3640BEGIN {
3641 our %SIGWATCHER = ();
3045 for my $signal (qw(INT HUP TERM)) { 3642 for my $signal (qw(INT HUP TERM)) {
3046 Event->signal ( 3643 $SIGWATCHER{$signal} = AE::signal $signal, sub {
3047 reentrant => 0,
3048 data => WF_AUTOCANCEL,
3049 signal => $signal,
3050 prio => 0,
3051 cb => sub {
3052 cf::cleanup "SIG$signal"; 3644 cf::cleanup "SIG$signal";
3053 },
3054 ); 3645 };
3055 } 3646 }
3056} 3647}
3057 3648
3058sub write_runtime { 3649sub write_runtime_sync {
3059 my $runtime = "$LOCALDIR/runtime"; 3650 my $t0 = AE::time;
3060 3651
3061 # first touch the runtime file to show we are still running: 3652 # first touch the runtime file to show we are still running:
3062 # the fsync below can take a very very long time. 3653 # the fsync below can take a very very long time.
3063 3654
3064 IO::AIO::aio_utime $runtime, undef, undef; 3655 IO::AIO::aio_utime $RUNTIMEFILE, undef, undef;
3065 3656
3066 my $guard = cf::lock_acquire "write_runtime"; 3657 my $guard = cf::lock_acquire "write_runtime";
3067 3658
3068 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 3659 my $fh = aio_open "$RUNTIMEFILE~", O_WRONLY | O_CREAT | O_TRUNC, 0644
3069 or return; 3660 or return;
3070 3661
3071 my $value = $cf::RUNTIME + 90 + 10; 3662 my $value = $cf::RUNTIME + 90 + 10;
3072 # 10 is the runtime save interval, for a monotonic clock 3663 # 10 is the runtime save interval, for a monotonic clock
3073 # 60 allows for the watchdog to kill the server. 3664 # 60 allows for the watchdog to kill the server.
3083 aio_utime $fh, undef, undef; 3674 aio_utime $fh, undef, undef;
3084 3675
3085 close $fh 3676 close $fh
3086 or return; 3677 or return;
3087 3678
3088 aio_rename "$runtime~", $runtime 3679 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3089 and return; 3680 and return;
3090 3681
3091 warn "runtime file written.\n"; 3682 warn sprintf "runtime file written (%gs).\n", AE::time - $t0;
3092 3683
3093 1 3684 1
3685}
3686
3687our $uuid_lock;
3688our $uuid_skip;
3689
3690sub write_uuid_sync($) {
3691 $uuid_skip ||= $_[0];
3692
3693 return if $uuid_lock;
3694 local $uuid_lock = 1;
3695
3696 my $uuid = "$LOCALDIR/uuid";
3697
3698 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3699 or return;
3700
3701 my $value = uuid_seq uuid_cur;
3702
3703 unless ($value) {
3704 warn "cowardly refusing to write zero uuid value!\n";
3705 return;
3706 }
3707
3708 my $value = uuid_str $value + $uuid_skip;
3709 $uuid_skip = 0;
3710
3711 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3712 and return;
3713
3714 # always fsync - this file is important
3715 aio_fsync $fh
3716 and return;
3717
3718 close $fh
3719 or return;
3720
3721 aio_rename "$uuid~", $uuid
3722 and return;
3723
3724 warn "uuid file written ($value).\n";
3725
3726 1
3727
3728}
3729
3730sub write_uuid($$) {
3731 my ($skip, $sync) = @_;
3732
3733 $sync ? write_uuid_sync $skip
3734 : async { write_uuid_sync $skip };
3094} 3735}
3095 3736
3096sub emergency_save() { 3737sub emergency_save() {
3097 my $freeze_guard = cf::freeze_mainloop; 3738 my $freeze_guard = cf::freeze_mainloop;
3098 3739
3099 warn "enter emergency perl save\n"; 3740 warn "emergency_perl_save: enter\n";
3100 3741
3101 cf::sync_job { 3742 cf::sync_job {
3743 # this is a trade-off: we want to be very quick here, so
3744 # save all maps without fsync, and later call a global sync
3745 # (which in turn might be very very slow)
3746 local $USE_FSYNC = 0;
3747
3102 # use a peculiar iteration method to avoid tripping on perl 3748 # use a peculiar iteration method to avoid tripping on perl
3103 # refcount bugs in for. also avoids problems with players 3749 # refcount bugs in for. also avoids problems with players
3104 # and maps saved/destroyed asynchronously. 3750 # and maps saved/destroyed asynchronously.
3105 warn "begin emergency player save\n"; 3751 warn "emergency_perl_save: begin player save\n";
3106 for my $login (keys %cf::PLAYER) { 3752 for my $login (keys %cf::PLAYER) {
3107 my $pl = $cf::PLAYER{$login} or next; 3753 my $pl = $cf::PLAYER{$login} or next;
3108 $pl->valid or next; 3754 $pl->valid or next;
3755 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3109 $pl->save; 3756 $pl->save;
3110 } 3757 }
3111 warn "end emergency player save\n"; 3758 warn "emergency_perl_save: end player save\n";
3112 3759
3113 warn "begin emergency map save\n"; 3760 warn "emergency_perl_save: begin map save\n";
3114 for my $path (keys %cf::MAP) { 3761 for my $path (keys %cf::MAP) {
3115 my $map = $cf::MAP{$path} or next; 3762 my $map = $cf::MAP{$path} or next;
3116 $map->valid or next; 3763 $map->valid or next;
3117 $map->save; 3764 $map->save;
3118 } 3765 }
3119 warn "end emergency map save\n"; 3766 warn "emergency_perl_save: end map save\n";
3120 3767
3121 warn "begin emergency database checkpoint\n"; 3768 warn "emergency_perl_save: begin database checkpoint\n";
3122 BDB::db_env_txn_checkpoint $DB_ENV; 3769 BDB::db_env_txn_checkpoint $DB_ENV;
3123 warn "end emergency database checkpoint\n"; 3770 warn "emergency_perl_save: end database checkpoint\n";
3771
3772 warn "emergency_perl_save: begin write uuid\n";
3773 write_uuid_sync 1;
3774 warn "emergency_perl_save: end write uuid\n";
3124 }; 3775 };
3125 3776
3777 warn "emergency_perl_save: starting sync()\n";
3778 IO::AIO::aio_sync sub {
3779 warn "emergency_perl_save: finished sync()\n";
3780 };
3781
3126 warn "leave emergency perl save\n"; 3782 warn "emergency_perl_save: leave\n";
3127} 3783}
3128 3784
3129sub post_cleanup { 3785sub post_cleanup {
3130 my ($make_core) = @_; 3786 my ($make_core) = @_;
3131 3787
3132 warn Carp::longmess "post_cleanup backtrace" 3788 warn Carp::longmess "post_cleanup backtrace"
3133 if $make_core; 3789 if $make_core;
3790
3791 my $fh = pidfile;
3792 unlink $PIDFILE if <$fh> == $$;
3793}
3794
3795# a safer delete_package, copied from Symbol
3796sub clear_package($) {
3797 my $pkg = shift;
3798
3799 # expand to full symbol table name if needed
3800 unless ($pkg =~ /^main::.*::$/) {
3801 $pkg = "main$pkg" if $pkg =~ /^::/;
3802 $pkg = "main::$pkg" unless $pkg =~ /^main::/;
3803 $pkg .= '::' unless $pkg =~ /::$/;
3804 }
3805
3806 my($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
3807 my $stem_symtab = *{$stem}{HASH};
3808
3809 defined $stem_symtab and exists $stem_symtab->{$leaf}
3810 or return;
3811
3812 # clear all symbols
3813 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3814 for my $name (keys %$leaf_symtab) {
3815 _gv_clear *{"$pkg$name"};
3816# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3817 }
3134} 3818}
3135 3819
3136sub do_reload_perl() { 3820sub do_reload_perl() {
3137 # can/must only be called in main 3821 # can/must only be called in main
3138 if ($Coro::current != $Coro::main) { 3822 if (in_main) {
3139 warn "can only reload from main coroutine"; 3823 warn "can only reload from main coroutine";
3140 return; 3824 return;
3141 } 3825 }
3142 3826
3827 return if $RELOAD++;
3828
3829 my $t1 = AE::time;
3830
3831 while ($RELOAD) {
3143 warn "reloading..."; 3832 warn "reloading...";
3144 3833
3145 warn "entering sync_job"; 3834 warn "entering sync_job";
3146 3835
3147 cf::sync_job { 3836 cf::sync_job {
3148 cf::write_runtime; # external watchdog should not bark 3837 cf::write_runtime_sync; # external watchdog should not bark
3149 cf::emergency_save; 3838 cf::emergency_save;
3150 cf::write_runtime; # external watchdog should not bark 3839 cf::write_runtime_sync; # external watchdog should not bark
3151 3840
3152 warn "syncing database to disk"; 3841 warn "syncing database to disk";
3153 BDB::db_env_txn_checkpoint $DB_ENV; 3842 BDB::db_env_txn_checkpoint $DB_ENV;
3154 3843
3155 # if anything goes wrong in here, we should simply crash as we already saved 3844 # if anything goes wrong in here, we should simply crash as we already saved
3156 3845
3157 warn "cancelling all WF_AUTOCANCEL watchers";
3158 for (Event::all_watchers) {
3159 $_->cancel if $_->data & WF_AUTOCANCEL;
3160 }
3161
3162 warn "flushing outstanding aio requests"; 3846 warn "flushing outstanding aio requests";
3163 for (;;) {
3164 BDB::flush;
3165 IO::AIO::flush;
3166 Coro::cede;
3167 last unless IO::AIO::nreqs || BDB::nreqs; 3847 while (IO::AIO::nreqs || BDB::nreqs) {
3168 warn "iterate..."; 3848 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3169 }
3170
3171 ++$RELOAD;
3172
3173 warn "cancelling all extension coros";
3174 $_->cancel for values %EXT_CORO;
3175 %EXT_CORO = ();
3176
3177 warn "removing commands";
3178 %COMMAND = ();
3179
3180 warn "removing ext/exti commands";
3181 %EXTCMD = ();
3182 %EXTICMD = ();
3183
3184 warn "unloading/nuking all extensions";
3185 for my $pkg (@EXTS) {
3186 warn "... unloading $pkg";
3187
3188 if (my $cb = $pkg->can ("unload")) {
3189 eval {
3190 $cb->($pkg);
3191 1
3192 } or warn "$pkg unloaded, but with errors: $@";
3193 } 3849 }
3194 3850
3195 warn "... nuking $pkg"; 3851 warn "cancelling all extension coros";
3196 Symbol::delete_package $pkg; 3852 $_->cancel for values %EXT_CORO;
3197 } 3853 %EXT_CORO = ();
3198 3854
3199 warn "unloading all perl modules loaded from $LIBDIR"; 3855 warn "removing commands";
3200 while (my ($k, $v) = each %INC) { 3856 %COMMAND = ();
3201 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3202 3857
3858 warn "removing ext/exti commands";
3859 %EXTCMD = ();
3860 %EXTICMD = ();
3861
3862 warn "unloading/nuking all extensions";
3863 for my $pkg (@EXTS) {
3203 warn "... unloading $k"; 3864 warn "... unloading $pkg";
3204 delete $INC{$k};
3205 3865
3206 $k =~ s/\.pm$//;
3207 $k =~ s/\//::/g;
3208
3209 if (my $cb = $k->can ("unload_module")) { 3866 if (my $cb = $pkg->can ("unload")) {
3867 eval {
3210 $cb->(); 3868 $cb->($pkg);
3869 1
3870 } or warn "$pkg unloaded, but with errors: $@";
3871 }
3872
3873 warn "... clearing $pkg";
3874 clear_package $pkg;
3211 } 3875 }
3212 3876
3213 Symbol::delete_package $k; 3877 warn "unloading all perl modules loaded from $LIBDIR";
3878 while (my ($k, $v) = each %INC) {
3879 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3880
3881 warn "... unloading $k";
3882 delete $INC{$k};
3883
3884 $k =~ s/\.pm$//;
3885 $k =~ s/\//::/g;
3886
3887 if (my $cb = $k->can ("unload_module")) {
3888 $cb->();
3889 }
3890
3891 clear_package $k;
3214 } 3892 }
3215 3893
3216 warn "getting rid of safe::, as good as possible"; 3894 warn "getting rid of safe::, as good as possible";
3217 Symbol::delete_package "safe::$_" 3895 clear_package "safe::$_"
3218 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3896 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3219 3897
3220 warn "unloading cf.pm \"a bit\""; 3898 warn "unloading cf.pm \"a bit\"";
3221 delete $INC{"cf.pm"}; 3899 delete $INC{"cf.pm"};
3222 delete $INC{"cf/pod.pm"}; 3900 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3223 3901
3224 # don't, removes xs symbols, too, 3902 # don't, removes xs symbols, too,
3225 # and global variables created in xs 3903 # and global variables created in xs
3226 #Symbol::delete_package __PACKAGE__; 3904 #clear_package __PACKAGE__;
3227 3905
3228 warn "unload completed, starting to reload now"; 3906 warn "unload completed, starting to reload now";
3229 3907
3230 warn "reloading cf.pm"; 3908 warn "reloading cf.pm";
3231 require cf; 3909 require cf;
3232 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3910 cf::_connect_to_perl_1;
3233 3911
3234 warn "loading config and database again"; 3912 warn "loading config and database again";
3235 cf::cfg_load; 3913 cf::reload_config;
3236 3914
3237 warn "loading extensions"; 3915 warn "loading extensions";
3238 cf::load_extensions; 3916 cf::load_extensions;
3239 3917
3918 if ($REATTACH_ON_RELOAD) {
3240 warn "reattaching attachments to objects/players"; 3919 warn "reattaching attachments to objects/players";
3241 _global_reattach; # objects, sockets 3920 _global_reattach; # objects, sockets
3242 warn "reattaching attachments to maps"; 3921 warn "reattaching attachments to maps";
3243 reattach $_ for values %MAP; 3922 reattach $_ for values %MAP;
3244 warn "reattaching attachments to players"; 3923 warn "reattaching attachments to players";
3245 reattach $_ for values %PLAYER; 3924 reattach $_ for values %PLAYER;
3925 }
3246 3926
3927 warn "running post_init jobs";
3928 (pop @POST_INIT)->(1) while @POST_INIT;
3929
3247 warn "leaving sync_job"; 3930 warn "leaving sync_job";
3248 3931
3249 1 3932 1
3250 } or do { 3933 } or do {
3251 warn $@; 3934 warn $@;
3252 warn "error while reloading, exiting."; 3935 cf::cleanup "error while reloading, exiting.";
3253 exit 1;
3254 }; 3936 };
3255 3937
3256 warn "reloaded"; 3938 warn "reloaded";
3939 --$RELOAD;
3940 }
3941
3942 $t1 = AE::time - $t1;
3943 warn "reload completed in ${t1}s\n";
3257}; 3944};
3258 3945
3259our $RELOAD_WATCHER; # used only during reload 3946our $RELOAD_WATCHER; # used only during reload
3260 3947
3261sub reload_perl() { 3948sub reload_perl() {
3262 # doing reload synchronously and two reloads happen back-to-back, 3949 # doing reload synchronously and two reloads happen back-to-back,
3263 # coro crashes during coro_state_free->destroy here. 3950 # coro crashes during coro_state_free->destroy here.
3264 3951
3265 $RELOAD_WATCHER ||= Event->timer ( 3952 $RELOAD_WATCHER ||= cf::async {
3266 reentrant => 0, 3953 Coro::AIO::aio_wait cache_extensions;
3267 after => 0, 3954
3268 data => WF_AUTOCANCEL, 3955 $RELOAD_WATCHER = AE::timer $TICK * 1.5, 0, sub {
3269 cb => sub {
3270 do_reload_perl; 3956 do_reload_perl;
3271 undef $RELOAD_WATCHER; 3957 undef $RELOAD_WATCHER;
3272 }, 3958 };
3273 ); 3959 };
3274} 3960}
3275 3961
3276register_command "reload" => sub { 3962register_command "reload" => sub {
3277 my ($who, $arg) = @_; 3963 my ($who, $arg) = @_;
3278 3964
3279 if ($who->flag (FLAG_WIZ)) { 3965 if ($who->flag (FLAG_WIZ)) {
3280 $who->message ("reloading server."); 3966 $who->message ("reloading server.");
3967 async {
3968 $Coro::current->{desc} = "perl_reload";
3281 async { reload_perl }; 3969 reload_perl;
3970 };
3282 } 3971 }
3283}; 3972};
3284 3973
3285unshift @INC, $LIBDIR; 3974unshift @INC, $LIBDIR;
3286 3975
3288 3977
3289our @WAIT_FOR_TICK; 3978our @WAIT_FOR_TICK;
3290our @WAIT_FOR_TICK_BEGIN; 3979our @WAIT_FOR_TICK_BEGIN;
3291 3980
3292sub wait_for_tick { 3981sub wait_for_tick {
3293 return unless $TICK_WATCHER->is_active;
3294 return if $Coro::current == $Coro::main; 3982 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3295 3983
3296 my $signal = new Coro::Signal; 3984 my $signal = new Coro::Signal;
3297 push @WAIT_FOR_TICK, $signal; 3985 push @WAIT_FOR_TICK, $signal;
3298 $signal->wait; 3986 $signal->wait;
3299} 3987}
3300 3988
3301sub wait_for_tick_begin { 3989sub wait_for_tick_begin {
3302 return unless $TICK_WATCHER->is_active;
3303 return if $Coro::current == $Coro::main; 3990 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3304 3991
3305 my $signal = new Coro::Signal; 3992 my $signal = new Coro::Signal;
3306 push @WAIT_FOR_TICK_BEGIN, $signal; 3993 push @WAIT_FOR_TICK_BEGIN, $signal;
3307 $signal->wait; 3994 $signal->wait;
3308} 3995}
3309 3996
3310 my $min = 1e6;#d# 3997sub tick {
3311 my $avg = 10;
3312$TICK_WATCHER = Event->timer (
3313 reentrant => 0,
3314 parked => 1,
3315 prio => 0,
3316 at => $NEXT_TICK || $TICK,
3317 data => WF_AUTOCANCEL,
3318 cb => sub {
3319 if ($Coro::current != $Coro::main) { 3998 if ($Coro::current != $Coro::main) {
3320 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3999 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3321 unless ++$bug_warning > 10; 4000 unless ++$bug_warning > 10;
3322 return; 4001 return;
3323 } 4002 }
3324 4003
3325 $NOW = $tick_start = Event::time;
3326
3327 cf::server_tick; # one server iteration 4004 cf::server_tick; # one server iteration
3328 4005
3329 0 && sync_job {#d# 4006 #for(1..3e6){} AE::now_update; $NOW=AE::now; # generate load #d#
3330 for(1..10) {
3331 my $t = Event::time;
3332 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3333 or die;
3334 4007
3335 $map->width (50); 4008 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3336 $map->height (50); 4009 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3337 $map->alloc; 4010 Coro::async_pool {
3338 $map->_load_objects ("/tmp/x.map", 1); 4011 $Coro::current->{desc} = "runtime saver";
3339 my $t = Event::time - $t; 4012 write_runtime_sync
3340 4013 or warn "ERROR: unable to write runtime file: $!";
3341 #next unless $t < 0.0013;#d#
3342 if ($t < $min) {
3343 $min = $t;
3344 }
3345 $avg = $avg * 0.99 + $t * 0.01;
3346 }
3347 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3348 exit 0;
3349 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3350 }; 4014 };
4015 }
3351 4016
3352 $RUNTIME += $TICK;
3353 $NEXT_TICK += $TICK;
3354
3355 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3356 $NEXT_RUNTIME_WRITE = $NOW + 10;
3357 Coro::async_pool {
3358 write_runtime
3359 or warn "ERROR: unable to write runtime file: $!";
3360 };
3361 }
3362
3363# my $AFTER = Event::time;
3364# warn $AFTER - $NOW;#d#
3365
3366 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4017 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3367 $sig->send; 4018 $sig->send;
3368 } 4019 }
3369 while (my $sig = shift @WAIT_FOR_TICK) { 4020 while (my $sig = shift @WAIT_FOR_TICK) {
3370 $sig->send; 4021 $sig->send;
3371 } 4022 }
3372 4023
3373 $NOW = Event::time; 4024 $LOAD = ($NOW - $TICK_START) / $TICK;
3374
3375 # if we are delayed by four ticks or more, skip them all
3376 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3377
3378 $TICK_WATCHER->at ($NEXT_TICK);
3379 $TICK_WATCHER->start;
3380
3381 $LOAD = ($NOW - $tick_start) / $TICK;
3382 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 4025 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3383 4026
3384 _post_tick; 4027 if (0) {
3385 4028 if ($NEXT_TICK) {
3386 4029 my $jitter = $TICK_START - $NEXT_TICK;
4030 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
4031 warn "jitter $JITTER\n";#d#
4032 }
3387 }, 4033 }
3388); 4034}
3389 4035
3390{ 4036{
3391 BDB::max_poll_time $TICK * 0.1; 4037 # configure BDB
3392 $BDB_POLL_WATCHER = Event->io ( 4038
3393 reentrant => 0,
3394 fd => BDB::poll_fileno,
3395 poll => 'r',
3396 prio => 0,
3397 data => WF_AUTOCANCEL,
3398 cb => \&BDB::poll_cb,
3399 );
3400 BDB::min_parallel 8; 4039 BDB::min_parallel 16;
3401 4040 BDB::max_poll_reqs $TICK * 0.1;
3402 BDB::set_sync_prepare { 4041 $AnyEvent::BDB::WATCHER->priority (1);
3403 my $status;
3404 my $current = $Coro::current;
3405 (
3406 sub {
3407 $status = $!;
3408 $current->ready; undef $current;
3409 },
3410 sub {
3411 Coro::schedule while defined $current;
3412 $! = $status;
3413 },
3414 )
3415 };
3416 4042
3417 unless ($DB_ENV) { 4043 unless ($DB_ENV) {
3418 $DB_ENV = BDB::db_env_create; 4044 $DB_ENV = BDB::db_env_create;
4045 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT);
4046 $DB_ENV->set_flags (&BDB::LOG_AUTOREMOVE ) if BDB::VERSION v0, v4.7;
4047 $DB_ENV->log_set_config (&BDB::LOG_AUTO_REMOVE) if BDB::VERSION v4.7;
4048 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
4049 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3419 4050
3420 cf::sync_job { 4051 cf::sync_job {
3421 eval { 4052 eval {
3422 BDB::db_env_open 4053 BDB::db_env_open
3423 $DB_ENV, 4054 $DB_ENV,
3425 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 4056 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3426 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 4057 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3427 0666; 4058 0666;
3428 4059
3429 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 4060 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3430
3431 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3432 $DB_ENV->set_lk_detect;
3433 }; 4061 };
3434 4062
3435 cf::cleanup "db_env_open(db): $@" if $@; 4063 cf::cleanup "db_env_open(db): $@" if $@;
3436 }; 4064 };
3437 } 4065 }
4066
4067 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
4068 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
4069 };
4070 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
4071 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
4072 };
4073 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
4074 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
4075 };
3438} 4076}
3439 4077
3440{ 4078{
4079 # configure IO::AIO
4080
3441 IO::AIO::min_parallel 8; 4081 IO::AIO::min_parallel 8;
3442
3443 undef $Coro::AIO::WATCHER;
3444 IO::AIO::max_poll_time $TICK * 0.1; 4082 IO::AIO::max_poll_time $TICK * 0.1;
3445 $AIO_POLL_WATCHER = Event->io ( 4083 undef $AnyEvent::AIO::WATCHER;
3446 reentrant => 0,
3447 data => WF_AUTOCANCEL,
3448 fd => IO::AIO::poll_fileno,
3449 poll => 'r',
3450 prio => 6,
3451 cb => \&IO::AIO::poll_cb,
3452 );
3453} 4084}
3454 4085
3455my $_log_backtrace; 4086my $_log_backtrace;
3456 4087
3457sub _log_backtrace { 4088sub _log_backtrace {
3460 $msg =~ s/\n//; 4091 $msg =~ s/\n//;
3461 4092
3462 # limit the # of concurrent backtraces 4093 # limit the # of concurrent backtraces
3463 if ($_log_backtrace < 2) { 4094 if ($_log_backtrace < 2) {
3464 ++$_log_backtrace; 4095 ++$_log_backtrace;
4096 my $perl_bt = Carp::longmess $msg;
3465 async { 4097 async {
4098 $Coro::current->{desc} = "abt $msg";
4099
3466 my @bt = fork_call { 4100 my @bt = fork_call {
3467 @addr = map { sprintf "%x", $_ } @addr; 4101 @addr = map { sprintf "%x", $_ } @addr;
3468 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 4102 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3469 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 4103 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3470 or die "addr2line: $!"; 4104 or die "addr2line: $!";
3478 } 4112 }
3479 4113
3480 @funcs 4114 @funcs
3481 }; 4115 };
3482 4116
3483 LOG llevInfo, "[ABT] $msg\n"; 4117 LOG llevInfo, "[ABT] $perl_bt\n";
4118 LOG llevInfo, "[ABT] --- C backtrace follows ---\n";
3484 LOG llevInfo, "[ABT] $_\n" for @bt; 4119 LOG llevInfo, "[ABT] $_\n" for @bt;
3485 --$_log_backtrace; 4120 --$_log_backtrace;
3486 }; 4121 };
3487 } else { 4122 } else {
3488 LOG llevInfo, "[ABT] $msg\n"; 4123 LOG llevInfo, "[ABT] $msg\n";
3489 LOG llevInfo, "[ABT] [suppressed]\n"; 4124 LOG llevInfo, "[ABT] [suppressed]\n";
3490 } 4125 }
3491} 4126}
3492 4127
3493# load additional modules 4128# load additional modules
3494use cf::pod; 4129require "cf/$_.pm" for @EXTRA_MODULES;
4130cf::_connect_to_perl_2;
3495 4131
3496END { cf::emergency_save } 4132END { cf::emergency_save }
3497 4133
34981 41341
3499 4135

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines