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

Diff Legend

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