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.166 by root, Sat Jan 13 23:06:13 2007 UTC vs.
Revision 1.435 by root, Thu May 29 03:33:20 2008 UTC

1#
2# This file is part of Deliantra, the Roguelike Realtime MMORPG.
3#
4# Copyright (©) 2006,2007,2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
5#
6# Deliantra is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your 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 GNU General Public License
17# along with this program. If not, see <http://www.gnu.org/licenses/>.
18#
19# The authors can be reached via e-mail to <support@deliantra.net>
20#
21
1package cf; 22package cf;
2 23
3use utf8; 24use utf8;
4use strict; 25use strict;
5 26
6use Symbol; 27use Symbol;
7use List::Util; 28use List::Util;
8use Storable; 29use Socket;
30use EV;
9use Opcode; 31use Opcode;
10use Safe; 32use Safe;
11use Safe::Hole; 33use Safe::Hole;
34use Storable ();
12 35
13use Coro 3.3 (); 36use Coro ();
37use Coro::State;
38use Coro::Handle;
14use Coro::Event; 39use Coro::AnyEvent;
15use Coro::Timer; 40use Coro::Timer;
16use Coro::Signal; 41use Coro::Signal;
17use Coro::Semaphore; 42use Coro::Semaphore;
43use Coro::AnyEvent;
18use Coro::AIO; 44use Coro::AIO;
45use Coro::BDB;
46use Coro::Storable;
47use Coro::Util ();
19 48
49use JSON::XS 2.01 ();
50use BDB ();
20use Data::Dumper; 51use Data::Dumper;
21use Digest::MD5; 52use Digest::MD5;
22use Fcntl; 53use Fcntl;
54use YAML ();
23use IO::AIO 2.32 (); 55use IO::AIO ();
24use YAML::Syck ();
25use Time::HiRes; 56use Time::HiRes;
57use Compress::LZF;
58use Digest::MD5 ();
26 59
27use Event; $Event::Eval = 1; # no idea why this is required, but it is 60AnyEvent::detect;
61
62# configure various modules to our taste
63#
64$Storable::canonical = 1; # reduce rsync transfers
65Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
66Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
67
68$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
28 69
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 70sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
32$YAML::Syck::ImplicitUnicode = 1;
33
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
35 71
36our %COMMAND = (); 72our %COMMAND = ();
37our %COMMAND_TIME = (); 73our %COMMAND_TIME = ();
38 74
39our @EXTS = (); # list of extension package names 75our @EXTS = (); # list of extension package names
40our %EXTCMD = (); 76our %EXTCMD = ();
77our %EXTICMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions 78our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps 79our %EXT_MAP = (); # pluggable maps
43 80
81our $RELOAD; # number of reloads so far
44our @EVENT; 82our @EVENT;
45our $LIBDIR = datadir . "/ext";
46 83
47our $TICK = MAX_TIME * 1e-6; 84our $CONFDIR = confdir;
48our $TICK_WATCHER; 85our $DATADIR = datadir;
86our $LIBDIR = "$DATADIR/ext";
87our $PODDIR = "$DATADIR/pod";
88our $MAPDIR = "$DATADIR/" . mapdir;
89our $LOCALDIR = localdir;
90our $TMPDIR = "$LOCALDIR/" . tmpdir;
91our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
92our $PLAYERDIR = "$LOCALDIR/" . playerdir;
93our $RANDOMDIR = "$LOCALDIR/random";
94our $BDBDIR = "$LOCALDIR/db";
95our %RESOURCE;
96
97our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
98our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
49our $NEXT_TICK; 99our $NEXT_TICK;
50our $NOW; 100our $USE_FSYNC = 1; # use fsync to write maps - default off
101
102our $BDB_DEADLOCK_WATCHER;
103our $BDB_CHECKPOINT_WATCHER;
104our $BDB_TRICKLE_WATCHER;
105our $DB_ENV;
51 106
52our %CFG; 107our %CFG;
53 108
54our $UPTIME; $UPTIME ||= time; 109our $UPTIME; $UPTIME ||= time;
55our $RUNTIME; 110our $RUNTIME;
111our $NOW;
56 112
57our %PLAYER; # all users 113our (%PLAYER, %PLAYER_LOADING); # all users
58our %MAP; # all maps 114our (%MAP, %MAP_LOADING ); # all maps
59our $LINK_MAP; # the special {link} map, which is always available 115our $LINK_MAP; # the special {link} map, which is always available
60our $RANDOM_MAPS = cf::localdir . "/random";
61
62our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
63our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
64 116
65# used to convert map paths into valid unix filenames by replacing / by ∕ 117# used to convert map paths into valid unix filenames by replacing / by ∕
66our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 118our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
67 119
120our $LOAD; # a number between 0 (idle) and 1 (too many objects)
121our $LOADAVG; # same thing, but with alpha-smoothing
122our $JITTER; # average jitter
123our $TICK_START; # for load detecting purposes
124
68binmode STDOUT; 125binmode STDOUT;
69binmode STDERR; 126binmode STDERR;
70 127
71# read virtual server time, if available 128# read virtual server time, if available
72unless ($RUNTIME || !-e cf::localdir . "/runtime") { 129unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
73 open my $fh, "<", cf::localdir . "/runtime" 130 open my $fh, "<", "$LOCALDIR/runtime"
74 or die "unable to read runtime file: $!"; 131 or die "unable to read runtime file: $!";
75 $RUNTIME = <$fh> + 0.; 132 $RUNTIME = <$fh> + 0.;
76} 133}
77 134
78mkdir cf::localdir; 135mkdir $_
79mkdir cf::localdir . "/" . cf::playerdir; 136 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
80mkdir cf::localdir . "/" . cf::tmpdir;
81mkdir cf::localdir . "/" . cf::uniquedir;
82mkdir $RANDOM_MAPS;
83 137
84our $EMERGENCY_POSITION; 138our $EMERGENCY_POSITION;
139
140sub cf::map::normalise;
85 141
86############################################################################# 142#############################################################################
87 143
88=head2 GLOBAL VARIABLES 144=head2 GLOBAL VARIABLES
89 145
… …
96=item $cf::RUNTIME 152=item $cf::RUNTIME
97 153
98The time this server has run, starts at 0 and is increased by $cf::TICK on 154The time this server has run, starts at 0 and is increased by $cf::TICK on
99every server tick. 155every server tick.
100 156
101=item $cf::LIBDIR 157=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
158$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
159$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
102 160
103The perl library directory, where extensions and cf-specific modules can 161Various directories - "/etc", read-only install directory, perl-library
104be found. It will be added to C<@INC> automatically. 162directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
163unique-items directory, player file directory, random maps directory and
164database environment.
105 165
106=item $cf::NOW 166=item $cf::NOW
107 167
108The time of the last (current) server tick. 168The time of the last (current) server tick.
109 169
110=item $cf::TICK 170=item $cf::TICK
111 171
112The interval between server ticks, in seconds. 172The interval between server ticks, in seconds.
113 173
174=item $cf::LOADAVG
175
176The current CPU load on the server (alpha-smoothed), as a value between 0
177(none) and 1 (overloaded), indicating how much time is spent on processing
178objects per tick. Healthy values are < 0.5.
179
180=item $cf::LOAD
181
182The raw value load value from the last tick.
183
114=item %cf::CFG 184=item %cf::CFG
115 185
116Configuration for the server, loaded from C</etc/crossfire/config>, or 186Configuration for the server, loaded from C</etc/deliantra-server/config>, or
117from wherever your confdir points to. 187from wherever your confdir points to.
118 188
119=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 189=item cf::wait_for_tick, cf::wait_for_tick_begin
120 190
121These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 191These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
122or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 192returns directly I<after> the tick processing (and consequently, can only wake one process
123processing has been done. Call C<< ->wait >> on them to maximise the 193per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
124window of cpu time available, or simply to synchronise to the server tick. 194
195=item @cf::INVOKE_RESULTS
196
197This array contains the results of the last C<invoke ()> call. When
198C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
199that call.
125 200
126=back 201=back
127 202
128=cut 203=cut
129 204
130BEGIN { 205BEGIN {
131 *CORE::GLOBAL::warn = sub { 206 *CORE::GLOBAL::warn = sub {
132 my $msg = join "", @_; 207 my $msg = join "", @_;
133 utf8::encode $msg;
134 208
135 $msg .= "\n" 209 $msg .= "\n"
136 unless $msg =~ /\n$/; 210 unless $msg =~ /\n$/;
137 211
212 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
213
138 LOG llevError, $msg; 214 LOG llevError, $msg;
139 }; 215 };
140} 216}
217
218$Coro::State::DIEHOOK = sub {
219 return unless $^S eq 0; # "eq", not "=="
220
221 if ($Coro::current == $Coro::main) {#d#
222 warn "DIEHOOK called in main context, Coro bug?\n";#d#
223 return;#d#
224 }#d#
225
226 # kill coroutine otherwise
227 warn Carp::longmess $_[0];
228 Coro::terminate
229};
230
231$SIG{__DIE__} = sub { }; #d#?
141 232
142@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 233@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
143@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 234@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
144@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 235@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
145@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 236@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
146@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 237@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
238@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
147@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 239@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
148 240
149# we bless all objects into (empty) derived classes to force a method lookup 241# we bless all objects into (empty) derived classes to force a method lookup
150# within the Safe compartment. 242# within the Safe compartment.
151for my $pkg (qw( 243for my $pkg (qw(
152 cf::global cf::attachable 244 cf::global cf::attachable
… …
157)) { 249)) {
158 no strict 'refs'; 250 no strict 'refs';
159 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 251 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
160} 252}
161 253
162$Event::DIED = sub { 254$EV::DIED = sub {
163 warn "error in event callback: @_"; 255 warn "error in event callback: @_";
164}; 256};
257
258#############################################################################
165 259
166=head2 UTILITY FUNCTIONS 260=head2 UTILITY FUNCTIONS
167 261
168=over 4 262=over 4
169 263
… …
188 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 282 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
189 $d 283 $d
190 } || "[unable to dump $_[0]: '$@']"; 284 } || "[unable to dump $_[0]: '$@']";
191} 285}
192 286
193use JSON::Syck (); # TODO# replace by JSON::PC once working
194
195=item $ref = cf::from_json $json 287=item $ref = cf::decode_json $json
196 288
197Converts a JSON string into the corresponding perl data structure. 289Converts a JSON string into the corresponding perl data structure.
198 290
199=cut
200
201sub from_json($) {
202 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
203 JSON::Syck::Load $_[0]
204}
205
206=item $json = cf::to_json $ref 291=item $json = cf::encode_json $ref
207 292
208Converts a perl data structure into its JSON representation. 293Converts a perl data structure into its JSON representation.
209 294
210=cut 295=cut
211 296
212sub to_json($) { 297our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
213 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 298
214 JSON::Syck::Dump $_[0] 299sub encode_json($) { $json_coder->encode ($_[0]) }
215} 300sub decode_json($) { $json_coder->decode ($_[0]) }
216 301
217=item cf::lock_wait $string 302=item cf::lock_wait $string
218 303
219Wait until the given lock is available. See cf::lock_acquire. 304Wait until the given lock is available. See cf::lock_acquire.
220 305
… …
223Wait until the given lock is available and then acquires it and returns 308Wait until the given lock is available and then acquires it and returns
224a Coro::guard object. If the guard object gets destroyed (goes out of scope, 309a Coro::guard object. If the guard object gets destroyed (goes out of scope,
225for example when the coroutine gets canceled), the lock is automatically 310for example when the coroutine gets canceled), the lock is automatically
226returned. 311returned.
227 312
313Locks are *not* recursive, locking from the same coro twice results in a
314deadlocked coro.
315
228Lock names should begin with a unique identifier (for example, cf::map::find 316Lock names should begin with a unique identifier (for example, cf::map::find
229uses map_find and cf::map::load uses map_load). 317uses map_find and cf::map::load uses map_load).
230 318
319=item $locked = cf::lock_active $string
320
321Return true if the lock is currently active, i.e. somebody has locked it.
322
231=cut 323=cut
232 324
233our %LOCK; 325our %LOCK;
326our %LOCKER;#d#
234 327
235sub lock_wait($) { 328sub lock_wait($) {
236 my ($key) = @_; 329 my ($key) = @_;
330
331 if ($LOCKER{$key} == $Coro::current) {#d#
332 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
333 return;#d#
334 }#d#
237 335
238 # wait for lock, if any 336 # wait for lock, if any
239 while ($LOCK{$key}) { 337 while ($LOCK{$key}) {
240 push @{ $LOCK{$key} }, $Coro::current; 338 push @{ $LOCK{$key} }, $Coro::current;
241 Coro::schedule; 339 Coro::schedule;
… …
247 345
248 # wait, to be sure we are not locked 346 # wait, to be sure we are not locked
249 lock_wait $key; 347 lock_wait $key;
250 348
251 $LOCK{$key} = []; 349 $LOCK{$key} = [];
350 $LOCKER{$key} = $Coro::current;#d#
252 351
253 Coro::guard { 352 Coro::guard {
353 delete $LOCKER{$key};#d#
254 # wake up all waiters, to be on the safe side 354 # wake up all waiters, to be on the safe side
255 $_->ready for @{ delete $LOCK{$key} }; 355 $_->ready for @{ delete $LOCK{$key} };
256 } 356 }
257} 357}
258 358
359sub lock_active($) {
360 my ($key) = @_;
361
362 ! ! $LOCK{$key}
363}
364
259sub freeze_mainloop { 365sub freeze_mainloop {
260 return unless $TICK_WATCHER->is_active; 366 tick_inhibit_inc;
261 367
262 my $guard = Coro::guard { $TICK_WATCHER->start }; 368 Coro::guard \&tick_inhibit_dec;
263 $TICK_WATCHER->stop; 369}
264 $guard 370
371=item cf::periodic $interval, $cb
372
373Like EV::periodic, but randomly selects a starting point so that the actions
374get spread over timer.
375
376=cut
377
378sub periodic($$) {
379 my ($interval, $cb) = @_;
380
381 my $start = rand List::Util::min 180, $interval;
382
383 EV::periodic $start, $interval, 0, $cb
384}
385
386=item cf::get_slot $time[, $priority[, $name]]
387
388Allocate $time seconds of blocking CPU time at priority C<$priority>:
389This call blocks and returns only when you have at least C<$time> seconds
390of cpu time till the next tick. The slot is only valid till the next cede.
391
392The optional C<$name> can be used to identify the job to run. It might be
393used for statistical purposes and should identify the same time-class.
394
395Useful for short background jobs.
396
397=cut
398
399our @SLOT_QUEUE;
400our $SLOT_QUEUE;
401
402$SLOT_QUEUE->cancel if $SLOT_QUEUE;
403$SLOT_QUEUE = Coro::async {
404 $Coro::current->desc ("timeslot manager");
405
406 my $signal = new Coro::Signal;
407
408 while () {
409 next_job:
410 my $avail = cf::till_tick;
411 if ($avail > 0.01) {
412 for (0 .. $#SLOT_QUEUE) {
413 if ($SLOT_QUEUE[$_][0] < $avail) {
414 my $job = splice @SLOT_QUEUE, $_, 1, ();
415 $job->[2]->send;
416 Coro::cede;
417 goto next_job;
418 }
419 }
420 }
421
422 if (@SLOT_QUEUE) {
423 # we do not use wait_for_tick() as it returns immediately when tick is inactive
424 push @cf::WAIT_FOR_TICK, $signal;
425 $signal->wait;
426 } else {
427 Coro::schedule;
428 }
429 }
430};
431
432sub get_slot($;$$) {
433 return if tick_inhibit || $Coro::current == $Coro::main;
434
435 my ($time, $pri, $name) = @_;
436
437 $time = $TICK * .6 if $time > $TICK * .6;
438 my $sig = new Coro::Signal;
439
440 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
441 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
442 $SLOT_QUEUE->ready;
443 $sig->wait;
265} 444}
266 445
267=item cf::async { BLOCK } 446=item cf::async { BLOCK }
268 447
269Currently the same as Coro::async_pool, meaning you cannot use 448Currently the same as Coro::async_pool, meaning you cannot use
… …
274 453
275BEGIN { *async = \&Coro::async_pool } 454BEGIN { *async = \&Coro::async_pool }
276 455
277=item cf::sync_job { BLOCK } 456=item cf::sync_job { BLOCK }
278 457
279The design of crossfire+ requires that the main coro ($Coro::main) is 458The design of Deliantra requires that the main coroutine ($Coro::main)
280always able to handle events or runnable, as crossfire+ is only partly 459is always able to handle events or runnable, as Deliantra is only
281reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 460partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
461acceptable.
282 462
283If it must be done, put the blocking parts into C<sync_job>. This will run 463If it must be done, put the blocking parts into C<sync_job>. This will run
284the given BLOCK in another coroutine while waiting for the result. The 464the given BLOCK in another coroutine while waiting for the result. The
285server will be frozen during this time, so the block should either finish 465server will be frozen during this time, so the block should either finish
286fast or be very important. 466fast or be very important.
… …
289 469
290sub sync_job(&) { 470sub sync_job(&) {
291 my ($job) = @_; 471 my ($job) = @_;
292 472
293 if ($Coro::current == $Coro::main) { 473 if ($Coro::current == $Coro::main) {
474 my $time = EV::time;
475
294 # this is the main coro, too bad, we have to block 476 # this is the main coro, too bad, we have to block
295 # till the operation succeeds, freezing the server :/ 477 # till the operation succeeds, freezing the server :/
296 478
297 # TODO: use suspend/resume instead 479 LOG llevError, Carp::longmess "sync job";#d#
298 # (but this is cancel-safe) 480
299 my $freeze_guard = freeze_mainloop; 481 my $freeze_guard = freeze_mainloop;
300 482
301 my $busy = 1; 483 my $busy = 1;
302 my @res; 484 my @res;
303 485
304 (async { 486 (async {
487 $Coro::current->desc ("sync job coro");
305 @res = eval { $job->() }; 488 @res = eval { $job->() };
306 warn $@ if $@; 489 warn $@ if $@;
307 undef $busy; 490 undef $busy;
308 })->prio (Coro::PRIO_MAX); 491 })->prio (Coro::PRIO_MAX);
309 492
310 while ($busy) { 493 while ($busy) {
311 Coro::cede or Event::one_event; 494 if (Coro::nready) {
495 Coro::cede_notself;
496 } else {
497 EV::loop EV::LOOP_ONESHOT;
312 } 498 }
499 }
500
501 my $time = EV::time - $time;
502
503 $TICK_START += $time; # do not account sync jobs to server load
313 504
314 wantarray ? @res : $res[0] 505 wantarray ? @res : $res[0]
315 } else { 506 } else {
316 # we are in another coroutine, how wonderful, everything just works 507 # we are in another coroutine, how wonderful, everything just works
317 508
… …
337 $EXT_CORO{$coro+0} = $coro; 528 $EXT_CORO{$coro+0} = $coro;
338 529
339 $coro 530 $coro
340} 531}
341 532
342sub write_runtime { 533=item fork_call { }, $args
343 return unless $TICK_WATCHER->is_active;
344 534
345 my $runtime = cf::localdir . "/runtime"; 535Executes the given code block with the given arguments in a seperate
536process, returning the results. Everything must be serialisable with
537Coro::Storable. May, of course, block. Note that the executed sub may
538never block itself or use any form of event handling.
346 539
347 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 540=cut
348 or return;
349 541
350 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 542sub fork_call(&@) {
351 (aio_write $fh, 0, (length $value), $value, 0) <= 0 543 my ($cb, @args) = @_;
352 and return;
353 544
354 aio_fsync $fh 545 # we seemingly have to make a local copy of the whole thing,
355 and return; 546 # otherwise perl prematurely frees the stuff :/
547 # TODO: investigate and fix (likely this will be rather laborious)
356 548
357 close $fh 549 my @res = Coro::Util::fork_eval {
358 or return; 550 reset_signals;
551 &$cb
552 }, @args;
359 553
360 aio_rename "$runtime~", $runtime 554 wantarray ? @res : $res[-1]
361 and return; 555}
362 556
557=item $coin = coin_from_name $name
558
559=cut
560
561our %coin_alias = (
562 "silver" => "silvercoin",
563 "silvercoin" => "silvercoin",
564 "silvercoins" => "silvercoin",
565 "gold" => "goldcoin",
566 "goldcoin" => "goldcoin",
567 "goldcoins" => "goldcoin",
568 "platinum" => "platinacoin",
569 "platinumcoin" => "platinacoin",
570 "platinumcoins" => "platinacoin",
571 "platina" => "platinacoin",
572 "platinacoin" => "platinacoin",
573 "platinacoins" => "platinacoin",
574 "royalty" => "royalty",
575 "royalties" => "royalty",
576);
577
578sub coin_from_name($) {
579 $coin_alias{$_[0]}
580 ? cf::arch::find $coin_alias{$_[0]}
581 : undef
582}
583
584=item $value = cf::db_get $family => $key
585
586Returns a single value from the environment database.
587
588=item cf::db_put $family => $key => $value
589
590Stores the given C<$value> in the family. It can currently store binary
591data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
592
593=item $db = cf::db_table "name"
594
595Create and/or open a new database table. The string must not be "db" and must be unique
596within each server.
597
598=cut
599
600sub db_table($) {
601 my ($name) = @_;
602 my $db = BDB::db_create $DB_ENV;
603
604 eval {
605 $db->set_flags (BDB::CHKSUM);
606
607 utf8::encode $name;
608 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
609 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
610 cf::cleanup "db_open(db): $!" if $!;
611 };
612 cf::cleanup "db_open(db): $@" if $@;
613
614 $db
615}
616
617our $DB;
618
619sub db_init {
620 cf::sync_job {
621 $DB ||= db_table "db";
622 };
623}
624
625sub db_get($$) {
626 my $key = "$_[0]/$_[1]";
627
628 cf::sync_job {
629 BDB::db_get $DB, undef, $key, my $data;
630
631 $! ? ()
632 : $data
363 1 633 }
634}
635
636sub db_put($$$) {
637 BDB::dbreq_pri 4;
638 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
639}
640
641=item cf::cache $id => [$paths...], $processversion => $process
642
643Generic caching function that returns the value of the resource $id,
644caching and regenerating as required.
645
646This function can block.
647
648=cut
649
650sub cache {
651 my ($id, $src, $processversion, $process) = @_;
652
653 my $meta =
654 join "\x00",
655 $processversion,
656 map {
657 aio_stat $_
658 and Carp::croak "$_: $!";
659
660 ($_, (stat _)[7,9])
661 } @$src;
662
663 my $dbmeta = db_get cache => "$id/meta";
664 if ($dbmeta ne $meta) {
665 # changed, we may need to process
666
667 my @data;
668 my $md5;
669
670 for (0 .. $#$src) {
671 0 <= aio_load $src->[$_], $data[$_]
672 or Carp::croak "$src->[$_]: $!";
673 }
674
675 # if processing is expensive, check
676 # checksum first
677 if (1) {
678 $md5 =
679 join "\x00",
680 $processversion,
681 map {
682 cf::cede_to_tick;
683 ($src->[$_], Digest::MD5::md5_hex $data[$_])
684 } 0.. $#$src;
685
686
687 my $dbmd5 = db_get cache => "$id/md5";
688 if ($dbmd5 eq $md5) {
689 db_put cache => "$id/meta", $meta;
690
691 return db_get cache => "$id/data";
692 }
693 }
694
695 my $t1 = Time::HiRes::time;
696 my $data = $process->(\@data);
697 my $t2 = Time::HiRes::time;
698
699 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
700
701 db_put cache => "$id/data", $data;
702 db_put cache => "$id/md5" , $md5;
703 db_put cache => "$id/meta", $meta;
704
705 return $data;
706 }
707
708 db_get cache => "$id/data"
709}
710
711=item cf::datalog type => key => value, ...
712
713Log a datalog packet of the given type with the given key-value pairs.
714
715=cut
716
717sub datalog($@) {
718 my ($type, %kv) = @_;
719 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
364} 720}
365 721
366=back 722=back
367 723
368=cut 724=cut
… …
375attach callbacks/event handlers (a collection of which is called an "attachment") 731attach callbacks/event handlers (a collection of which is called an "attachment")
376to it. All such attachable objects support the following methods. 732to it. All such attachable objects support the following methods.
377 733
378In the following description, CLASS can be any of C<global>, C<object> 734In the following description, CLASS can be any of C<global>, C<object>
379C<player>, C<client> or C<map> (i.e. the attachable objects in 735C<player>, C<client> or C<map> (i.e. the attachable objects in
380crossfire+). 736Deliantra).
381 737
382=over 4 738=over 4
383 739
384=item $attachable->attach ($attachment, key => $value...) 740=item $attachable->attach ($attachment, key => $value...)
385 741
… …
499our @CB_TYPE = (); # registry for type (cf-object class) based events 855our @CB_TYPE = (); # registry for type (cf-object class) based events
500our @CB_MAP = (); 856our @CB_MAP = ();
501 857
502my %attachment; 858my %attachment;
503 859
860sub cf::attachable::thawer_merge {
861 # simply override everything except _meta
862 local $_[0]{_meta};
863 %{$_[0]} = %{$_[1]};
864}
865
504sub _attach_cb($$$$) { 866sub _attach_cb($$$$) {
505 my ($registry, $event, $prio, $cb) = @_; 867 my ($registry, $event, $prio, $cb) = @_;
506 868
507 use sort 'stable'; 869 use sort 'stable';
508 870
… …
542 $registry = $CB_TYPE[$object_type] ||= []; 904 $registry = $CB_TYPE[$object_type] ||= [];
543 905
544 } elsif ($type eq "subtype") { 906 } elsif ($type eq "subtype") {
545 defined $object_type or Carp::croak "subtype specified without type"; 907 defined $object_type or Carp::croak "subtype specified without type";
546 my $object_subtype = shift @arg; 908 my $object_subtype = shift @arg;
547 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 909 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
548 910
549 } elsif ($type eq "package") { 911 } elsif ($type eq "package") {
550 my $pkg = shift @arg; 912 my $pkg = shift @arg;
551 913
552 while (my ($name, $id) = each %cb_id) { 914 while (my ($name, $id) = each %cb_id) {
… …
581 _attach $registry, $klass, @attach; 943 _attach $registry, $klass, @attach;
582 } 944 }
583 945
584 $obj->{$name} = \%arg; 946 $obj->{$name} = \%arg;
585 } else { 947 } else {
586 warn "object uses attachment '$name' that is not available, postponing.\n"; 948 warn "object uses attachment '$name' which is not available, postponing.\n";
587 } 949 }
588 950
589 $obj->{_attachment}{$name} = undef; 951 $obj->{_attachment}{$name} = undef;
590} 952}
591 953
… …
593 if (ref $_[0]) { 955 if (ref $_[0]) {
594 _object_attach @_; 956 _object_attach @_;
595 } else { 957 } else {
596 _attach shift->_attach_registry, @_; 958 _attach shift->_attach_registry, @_;
597 } 959 }
960 _recalc_want;
598}; 961};
599 962
600# all those should be optimised 963# all those should be optimised
601sub cf::attachable::detach { 964sub cf::attachable::detach {
602 my ($obj, $name) = @_; 965 my ($obj, $name) = @_;
… …
605 delete $obj->{_attachment}{$name}; 968 delete $obj->{_attachment}{$name};
606 reattach ($obj); 969 reattach ($obj);
607 } else { 970 } else {
608 Carp::croak "cannot, currently, detach class attachments"; 971 Carp::croak "cannot, currently, detach class attachments";
609 } 972 }
973 _recalc_want;
610}; 974};
611 975
612sub cf::attachable::attached { 976sub cf::attachable::attached {
613 my ($obj, $name) = @_; 977 my ($obj, $name) = @_;
614 978
… …
629 "; 993 ";
630 die if $@; 994 die if $@;
631} 995}
632 996
633our $override; 997our $override;
634our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 998our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
635 999
636sub override { 1000sub override {
637 $override = 1; 1001 $override = 1;
638 @invoke_results = (); 1002 @INVOKE_RESULTS = (@_);
639} 1003}
640 1004
641sub do_invoke { 1005sub do_invoke {
642 my $event = shift; 1006 my $event = shift;
643 my $callbacks = shift; 1007 my $callbacks = shift;
644 1008
645 @invoke_results = (); 1009 @INVOKE_RESULTS = ();
646 1010
647 local $override; 1011 local $override;
648 1012
649 for (@$callbacks) { 1013 for (@$callbacks) {
650 eval { &{$_->[1]} }; 1014 eval { &{$_->[1]} };
… …
659 } 1023 }
660 1024
661 0 1025 0
662} 1026}
663 1027
664=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 1028=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
665 1029
666=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 1030=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
667 1031
668Generate an object-specific event with the given arguments. 1032Generate an object-specific event with the given arguments.
669 1033
670This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 1034This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
671removed in future versions), and there is no public API to access override 1035removed in future versions), and there is no public API to access override
672results (if you must, access C<@cf::invoke_results> directly). 1036results (if you must, access C<@cf::INVOKE_RESULTS> directly).
673 1037
674=back 1038=back
675 1039
676=cut 1040=cut
677 1041
678############################################################################# 1042#############################################################################
679# object support 1043# object support
1044
1045sub _object_equal($$);
1046sub _object_equal($$) {
1047 my ($a, $b) = @_;
1048
1049 return 0 unless (ref $a) eq (ref $b);
1050
1051 if ("HASH" eq ref $a) {
1052 my @ka = keys %$a;
1053 my @kb = keys %$b;
1054
1055 return 0 if @ka != @kb;
1056
1057 for (0 .. $#ka) {
1058 return 0 unless $ka[$_] eq $kb[$_];
1059 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1060 }
1061
1062 } elsif ("ARRAY" eq ref $a) {
1063
1064 return 0 if @$a != @$b;
1065
1066 for (0 .. $#$a) {
1067 return 0 unless _object_equal $a->[$_], $b->[$_];
1068 }
1069
1070 } elsif ($a ne $b) {
1071 return 0;
1072 }
1073
1074 1
1075}
1076
1077our $SLOW_MERGES;#d#
1078sub _can_merge {
1079 my ($ob1, $ob2) = @_;
1080
1081 ++$SLOW_MERGES;#d#
1082
1083 # we do the slow way here
1084 return _object_equal $ob1, $ob2
1085}
680 1086
681sub reattach { 1087sub reattach {
682 # basically do the same as instantiate, without calling instantiate 1088 # basically do the same as instantiate, without calling instantiate
683 my ($obj) = @_; 1089 my ($obj) = @_;
1090
1091 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
684 1092
685 my $registry = $obj->registry; 1093 my $registry = $obj->registry;
686 1094
687 @$registry = (); 1095 @$registry = ();
688 1096
… …
703cf::attachable->attach ( 1111cf::attachable->attach (
704 prio => -1000000, 1112 prio => -1000000,
705 on_instantiate => sub { 1113 on_instantiate => sub {
706 my ($obj, $data) = @_; 1114 my ($obj, $data) = @_;
707 1115
708 $data = from_json $data; 1116 $data = decode_json $data;
709 1117
710 for (@$data) { 1118 for (@$data) {
711 my ($name, $args) = @$_; 1119 my ($name, $args) = @$_;
712 1120
713 $obj->attach ($name, %{$args || {} }); 1121 $obj->attach ($name, %{$args || {} });
… …
729sub object_freezer_save { 1137sub object_freezer_save {
730 my ($filename, $rdata, $objs) = @_; 1138 my ($filename, $rdata, $objs) = @_;
731 1139
732 sync_job { 1140 sync_job {
733 if (length $$rdata) { 1141 if (length $$rdata) {
1142 utf8::decode (my $decname = $filename);
734 warn sprintf "saving %s (%d,%d)\n", 1143 warn sprintf "saving %s (%d,%d)\n",
735 $filename, length $$rdata, scalar @$objs; 1144 $decname, length $$rdata, scalar @$objs;
736 1145
737 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1146 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
738 chmod SAVE_MODE, $fh; 1147 aio_chmod $fh, SAVE_MODE;
739 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1148 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
740 aio_fsync $fh; 1149 aio_fsync $fh if $cf::USE_FSYNC;
741 close $fh; 1150 aio_close $fh;
742 1151
743 if (@$objs) { 1152 if (@$objs) {
744 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1153 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
745 chmod SAVE_MODE, $fh; 1154 aio_chmod $fh, SAVE_MODE;
746 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1155 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
747 aio_write $fh, 0, (length $data), $data, 0; 1156 aio_write $fh, 0, (length $data), $data, 0;
748 aio_fsync $fh; 1157 aio_fsync $fh if $cf::USE_FSYNC;
749 close $fh; 1158 aio_close $fh;
750 aio_rename "$filename.pst~", "$filename.pst"; 1159 aio_rename "$filename.pst~", "$filename.pst";
751 } 1160 }
752 } else { 1161 } else {
753 aio_unlink "$filename.pst"; 1162 aio_unlink "$filename.pst";
754 } 1163 }
… …
759 } 1168 }
760 } else { 1169 } else {
761 aio_unlink $filename; 1170 aio_unlink $filename;
762 aio_unlink "$filename.pst"; 1171 aio_unlink "$filename.pst";
763 } 1172 }
764 } 1173 };
765} 1174}
766 1175
767sub object_freezer_as_string { 1176sub object_freezer_as_string {
768 my ($rdata, $objs) = @_; 1177 my ($rdata, $objs) = @_;
769 1178
… …
781 or return; 1190 or return;
782 1191
783 unless (aio_stat "$filename.pst") { 1192 unless (aio_stat "$filename.pst") {
784 (aio_load "$filename.pst", $av) >= 0 1193 (aio_load "$filename.pst", $av) >= 0
785 or return; 1194 or return;
1195
786 $av = eval { (Storable::thaw $av)->{objs} }; 1196 my $st = eval { Coro::Storable::thaw $av };
1197 $av = $st->{objs};
787 } 1198 }
788 1199
1200 utf8::decode (my $decname = $filename);
789 warn sprintf "loading %s (%d)\n", 1201 warn sprintf "loading %s (%d,%d)\n",
790 $filename, length $data, scalar @{$av || []};#d# 1202 $decname, length $data, scalar @{$av || []};
1203
791 return ($data, $av); 1204 ($data, $av)
792} 1205}
1206
1207=head2 COMMAND CALLBACKS
1208
1209=over 4
1210
1211=cut
793 1212
794############################################################################# 1213#############################################################################
795# command handling &c 1214# command handling &c
796 1215
797=item cf::register_command $name => \&callback($ob,$args); 1216=item cf::register_command $name => \&callback($ob,$args);
… …
810 push @{ $COMMAND{$name} }, [$caller, $cb]; 1229 push @{ $COMMAND{$name} }, [$caller, $cb];
811} 1230}
812 1231
813=item cf::register_extcmd $name => \&callback($pl,$packet); 1232=item cf::register_extcmd $name => \&callback($pl,$packet);
814 1233
815Register a callbackf ro execution when the client sends an extcmd packet. 1234Register a callback for execution when the client sends an (synchronous)
1235extcmd packet. Ext commands will be processed in the order they are
1236received by the server, like other user commands. The first argument is
1237the logged-in player. Ext commands can only be processed after a player
1238has logged in successfully.
816 1239
817If the callback returns something, it is sent back as if reply was being 1240If the callback returns something, it is sent back as if reply was being
818called. 1241called.
819 1242
1243=item cf::register_exticmd $name => \&callback($ns,$packet);
1244
1245Register a callback for execution when the client sends an (asynchronous)
1246exticmd packet. Exti commands are processed by the server as soon as they
1247are received, i.e. out of order w.r.t. other commands. The first argument
1248is a client socket. Exti commands can be received anytime, even before
1249log-in.
1250
1251If the callback returns something, it is sent back as if reply was being
1252called.
1253
820=cut 1254=cut
821 1255
822sub register_extcmd { 1256sub register_extcmd {
823 my ($name, $cb) = @_; 1257 my ($name, $cb) = @_;
824 1258
825 $EXTCMD{$name} = $cb; 1259 $EXTCMD{$name} = $cb;
1260}
1261
1262sub register_exticmd {
1263 my ($name, $cb) = @_;
1264
1265 $EXTICMD{$name} = $cb;
826} 1266}
827 1267
828cf::player->attach ( 1268cf::player->attach (
829 on_command => sub { 1269 on_command => sub {
830 my ($pl, $name, $params) = @_; 1270 my ($pl, $name, $params) = @_;
… …
839 cf::override; 1279 cf::override;
840 }, 1280 },
841 on_extcmd => sub { 1281 on_extcmd => sub {
842 my ($pl, $buf) = @_; 1282 my ($pl, $buf) = @_;
843 1283
844 my $msg = eval { from_json $buf }; 1284 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
845 1285
846 if (ref $msg) { 1286 if (ref $msg) {
1287 my ($type, $reply, @payload) =
1288 "ARRAY" eq ref $msg
1289 ? @$msg
1290 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1291
1292 my @reply;
1293
847 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1294 if (my $cb = $EXTCMD{$type}) {
848 if (my %reply = $cb->($pl, $msg)) { 1295 @reply = $cb->($pl, @payload);
849 $pl->ext_reply ($msg->{msgid}, %reply);
850 }
851 } 1296 }
1297
1298 $pl->ext_reply ($reply, @reply)
1299 if $reply;
1300
852 } else { 1301 } else {
853 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1302 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
854 } 1303 }
855 1304
856 cf::override; 1305 cf::override;
857 }, 1306 },
858); 1307);
859 1308
860sub load_extension {
861 my ($path) = @_;
862
863 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
864 my $base = $1;
865 my $pkg = $1;
866 $pkg =~ s/[^[:word:]]/_/g;
867 $pkg = "ext::$pkg";
868
869 warn "... loading '$path' into '$pkg'\n";
870
871 open my $fh, "<:utf8", $path
872 or die "$path: $!";
873
874 my $source =
875 "package $pkg; use strict; use utf8;\n"
876 . "#line 1 \"$path\"\n{\n"
877 . (do { local $/; <$fh> })
878 . "\n};\n1";
879
880 unless (eval $source) {
881 my $msg = $@ ? "$path: $@\n"
882 : "extension disabled.\n";
883 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
884 warn $@;
885 warn "mandatory extension failed to load, exiting.\n";
886 exit 1;
887 }
888 die $@;
889 }
890
891 push @EXTS, $pkg;
892}
893
894sub load_extensions { 1309sub load_extensions {
1310 cf::sync_job {
1311 my %todo;
1312
895 for my $ext (<$LIBDIR/*.ext>) { 1313 for my $path (<$LIBDIR/*.ext>) {
896 next unless -r $ext; 1314 next unless -r $path;
897 eval { 1315
898 load_extension $ext; 1316 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1317 my $base = $1;
1318 my $pkg = $1;
1319 $pkg =~ s/[^[:word:]]/_/g;
1320 $pkg = "ext::$pkg";
1321
1322 open my $fh, "<:utf8", $path
1323 or die "$path: $!";
1324
1325 my $source = do { local $/; <$fh> };
1326
1327 my %ext = (
1328 path => $path,
1329 base => $base,
1330 pkg => $pkg,
1331 );
1332
1333 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1334 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1335
1336 $ext{source} =
1337 "package $pkg; use strict; use utf8;\n"
1338 . "#line 1 \"$path\"\n{\n"
1339 . $source
1340 . "\n};\n1";
1341
1342 $todo{$base} = \%ext;
1343 }
1344
1345 my %done;
1346 while (%todo) {
1347 my $progress;
1348
1349 while (my ($k, $v) = each %todo) {
1350 for (split /,\s*/, $v->{meta}{depends}) {
1351 goto skip
1352 unless exists $done{$_};
1353 }
1354
1355 warn "... loading '$k' into '$v->{pkg}'\n";
1356
1357 unless (eval $v->{source}) {
1358 my $msg = $@ ? "$v->{path}: $@\n"
1359 : "$v->{base}: extension inactive.\n";
1360
1361 if (exists $v->{meta}{mandatory}) {
1362 warn $msg;
1363 cf::cleanup "mandatory extension failed to load, exiting.";
1364 }
1365
1366 warn $msg;
1367 }
1368
1369 $done{$k} = delete $todo{$k};
1370 push @EXTS, $v->{pkg};
1371 $progress = 1;
899 1 1372 }
900 } or warn "$ext not loaded: $@"; 1373
1374 skip:
1375 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1376 unless $progress;
1377 }
901 } 1378 };
902} 1379}
903 1380
904############################################################################# 1381#############################################################################
905# load/save/clean perl data associated with a map
906 1382
907*cf::mapsupport::on_clean = sub { 1383=back
908 my ($map) = @_;
909
910 my $path = $map->tmpname;
911 defined $path or return;
912
913 unlink "$path.pst";
914};
915
916cf::map->attach (prio => -10000, package => cf::mapsupport::);
917
918#############################################################################
919 1384
920=head2 CORE EXTENSIONS 1385=head2 CORE EXTENSIONS
921 1386
922Functions and methods that extend core crossfire objects. 1387Functions and methods that extend core crossfire objects.
923 1388
… …
929 1394
930=head3 cf::player 1395=head3 cf::player
931 1396
932=over 4 1397=over 4
933 1398
1399=item cf::player::num_playing
1400
1401Returns the official number of playing players, as per the Crossfire metaserver rules.
1402
1403=cut
1404
1405sub num_playing {
1406 scalar grep
1407 $_->ob->map
1408 && !$_->hidden
1409 && !$_->ob->flag (cf::FLAG_WIZ),
1410 cf::player::list
1411}
1412
934=item cf::player::find $login 1413=item cf::player::find $login
935 1414
936Returns the given player object, loading it if necessary (might block). 1415Returns the given player object, loading it if necessary (might block).
937 1416
938=cut 1417=cut
939 1418
940sub playerdir($) { 1419sub playerdir($) {
941 cf::localdir 1420 "$PLAYERDIR/"
942 . "/"
943 . cf::playerdir
944 . "/"
945 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1421 . (ref $_[0] ? $_[0]->ob->name : $_[0])
946} 1422}
947 1423
948sub path($) { 1424sub path($) {
949 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1425 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
950 1426
951 (playerdir $login) . "/$login.pl" 1427 (playerdir $login) . "/playerdata"
952} 1428}
953 1429
954sub find_active($) { 1430sub find_active($) {
955 $cf::PLAYER{$_[0]} 1431 $cf::PLAYER{$_[0]}
956 and $cf::PLAYER{$_[0]}->active 1432 and $cf::PLAYER{$_[0]}->active
… …
959 1435
960sub exists($) { 1436sub exists($) {
961 my ($login) = @_; 1437 my ($login) = @_;
962 1438
963 $cf::PLAYER{$login} 1439 $cf::PLAYER{$login}
964 or cf::sync_job { !aio_stat $login } 1440 or cf::sync_job { !aio_stat path $login }
965} 1441}
966 1442
967sub find($) { 1443sub find($) {
968 return $cf::PLAYER{$_[0]} || do { 1444 return $cf::PLAYER{$_[0]} || do {
969 my $login = $_[0]; 1445 my $login = $_[0];
970 1446
971 my $guard = cf::lock_acquire "user_find:$login"; 1447 my $guard = cf::lock_acquire "user_find:$login";
972 1448
973 $cf::PLAYER{$_[0]} || do { 1449 $cf::PLAYER{$_[0]} || do {
974 my $pl = load_pl path $login 1450 # rename old playerfiles to new ones
1451 #TODO: remove when no longer required
1452 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1453 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1454 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1455 aio_unlink +(playerdir $login) . "/$login.pl";
1456
1457 my $f = new_from_file cf::object::thawer path $login
975 or return; 1458 or return;
1459
1460 my $pl = cf::player::load_pl $f
1461 or return;
1462
1463 local $cf::PLAYER_LOADING{$login} = $pl;
1464 $f->resolve_delayed_derefs;
976 $cf::PLAYER{$login} = $pl 1465 $cf::PLAYER{$login} = $pl
977 } 1466 }
978 } 1467 }
979} 1468}
980 1469
… …
989 return if $pl->{deny_save}; 1478 return if $pl->{deny_save};
990 1479
991 aio_mkdir playerdir $pl, 0770; 1480 aio_mkdir playerdir $pl, 0770;
992 $pl->{last_save} = $cf::RUNTIME; 1481 $pl->{last_save} = $cf::RUNTIME;
993 1482
1483 cf::get_slot 0.01;
1484
994 $pl->save_pl ($path); 1485 $pl->save_pl ($path);
995 Coro::cede; 1486 cf::cede_to_tick;
996} 1487}
997 1488
998sub new($) { 1489sub new($) {
999 my ($login) = @_; 1490 my ($login) = @_;
1000 1491
… …
1006 $cf::PLAYER{$login} = $self; 1497 $cf::PLAYER{$login} = $self;
1007 1498
1008 $self 1499 $self
1009} 1500}
1010 1501
1502=item $player->send_msg ($channel, $msg, $color, [extra...])
1503
1504=cut
1505
1506sub send_msg {
1507 my $ns = shift->ns
1508 or return;
1509 $ns->send_msg (@_);
1510}
1511
1011=item $pl->quit_character 1512=item $pl->quit_character
1012 1513
1013Nukes the player without looking back. If logged in, the connection will 1514Nukes the player without looking back. If logged in, the connection will
1014be destroyed. May block for a long time. 1515be destroyed. May block for a long time.
1015 1516
1016=cut 1517=cut
1017 1518
1018sub quit_character { 1519sub quit_character {
1019 my ($pl) = @_; 1520 my ($pl) = @_;
1020 1521
1522 my $name = $pl->ob->name;
1523
1021 $pl->{deny_save} = 1; 1524 $pl->{deny_save} = 1;
1022 $pl->password ("*"); # this should lock out the player until we nuked the dir 1525 $pl->password ("*"); # this should lock out the player until we nuked the dir
1023 1526
1024 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1527 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1025 $pl->deactivate; 1528 $pl->deactivate;
1529 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1530 $pl->ob->check_score;
1026 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1531 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1027 $pl->ns->destroy if $pl->ns; 1532 $pl->ns->destroy if $pl->ns;
1028 1533
1029 my $path = playerdir $pl; 1534 my $path = playerdir $pl;
1030 my $temp = "$path~$cf::RUNTIME~deleting~"; 1535 my $temp = "$path~$cf::RUNTIME~deleting~";
1031 aio_rename $path, $temp; 1536 aio_rename $path, $temp;
1032 delete $cf::PLAYER{$pl->ob->name}; 1537 delete $cf::PLAYER{$pl->ob->name};
1033 $pl->destroy; 1538 $pl->destroy;
1539
1540 my $prefix = qr<^~\Q$name\E/>;
1541
1542 # nuke player maps
1543 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1544
1034 IO::AIO::aio_rmtree $temp; 1545 IO::AIO::aio_rmtree $temp;
1546}
1547
1548=item $pl->kick
1549
1550Kicks a player out of the game. This destroys the connection.
1551
1552=cut
1553
1554sub kick {
1555 my ($pl, $kicker) = @_;
1556
1557 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1558 $pl->killer ("kicked");
1559 $pl->ns->destroy;
1035} 1560}
1036 1561
1037=item cf::player::list_logins 1562=item cf::player::list_logins
1038 1563
1039Returns am arrayref of all valid playernames in the system, can take a 1564Returns am arrayref of all valid playernames in the system, can take a
1040while and may block, so not sync_job-capable, ever. 1565while and may block, so not sync_job-capable, ever.
1041 1566
1042=cut 1567=cut
1043 1568
1044sub list_logins { 1569sub list_logins {
1045 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1570 my $dirs = aio_readdir $PLAYERDIR
1046 or return []; 1571 or return [];
1047 1572
1048 my @logins; 1573 my @logins;
1049 1574
1050 for my $login (@$dirs) { 1575 for my $login (@$dirs) {
1576 my $path = path $login;
1577
1578 # a .pst is a dead give-away for a valid player
1579 # if no pst file found, open and chekc for blocked users
1580 if (aio_stat "$path.pst") {
1051 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1581 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1052 aio_read $fh, 0, 512, my $buf, 0 or next; 1582 aio_read $fh, 0, 512, my $buf, 0 or next;
1053 $buf !~ /^password -------------$/m or next; # official not-valid tag 1583 $buf !~ /^password -------------$/m or next; # official not-valid tag
1584 }
1054 1585
1055 utf8::decode $login; 1586 utf8::decode $login;
1056 push @logins, $login; 1587 push @logins, $login;
1057 } 1588 }
1058 1589
… …
1066 1597
1067=cut 1598=cut
1068 1599
1069sub maps($) { 1600sub maps($) {
1070 my ($pl) = @_; 1601 my ($pl) = @_;
1602
1603 $pl = ref $pl ? $pl->ob->name : $pl;
1071 1604
1072 my $files = aio_readdir playerdir $pl 1605 my $files = aio_readdir playerdir $pl
1073 or return; 1606 or return;
1074 1607
1075 my @paths; 1608 my @paths;
… …
1077 for (@$files) { 1610 for (@$files) {
1078 utf8::decode $_; 1611 utf8::decode $_;
1079 next if /\.(?:pl|pst)$/; 1612 next if /\.(?:pl|pst)$/;
1080 next unless /^$PATH_SEP/o; 1613 next unless /^$PATH_SEP/o;
1081 1614
1082 push @paths, "~" . $pl->ob->name . "/" . $_; 1615 push @paths, cf::map::normalise "~$pl/$_";
1083 } 1616 }
1084 1617
1085 \@paths 1618 \@paths
1086} 1619}
1087 1620
1621=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1622
1623Expand crossfire pod fragments into protocol xml.
1624
1625=cut
1626
1627use re 'eval';
1628
1629my $group;
1630my $interior; $interior = qr{
1631 # match a pod interior sequence sans C<< >>
1632 (?:
1633 \ (.*?)\ (?{ $group = $^N })
1634 | < (??{$interior}) >
1635 )
1636}x;
1637
1638sub expand_cfpod {
1639 my ($self, $pod) = @_;
1640
1641 my $xml;
1642
1643 while () {
1644 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1645 $group = $1;
1646
1647 $group =~ s/&/&amp;/g;
1648 $group =~ s/</&lt;/g;
1649
1650 $xml .= $group;
1651 } elsif ($pod =~ m%\G
1652 ([BCGHITU])
1653 <
1654 (?:
1655 ([^<>]*) (?{ $group = $^N })
1656 | < $interior >
1657 )
1658 >
1659 %gcsx
1660 ) {
1661 my ($code, $data) = ($1, $group);
1662
1663 if ($code eq "B") {
1664 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1665 } elsif ($code eq "I") {
1666 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1667 } elsif ($code eq "U") {
1668 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1669 } elsif ($code eq "C") {
1670 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1671 } elsif ($code eq "T") {
1672 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1673 } elsif ($code eq "G") {
1674 my ($male, $female) = split /\|/, $data;
1675 $data = $self->gender ? $female : $male;
1676 $xml .= expand_cfpod ($self, $data);
1677 } elsif ($code eq "H") {
1678 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1679 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1680 "")
1681 [$self->{hintmode}];
1682 } else {
1683 $xml .= "error processing '$code($data)' directive";
1684 }
1685 } else {
1686 if ($pod =~ /\G(.+)/) {
1687 warn "parse error while expanding $pod (at $1)";
1688 }
1689 last;
1690 }
1691 }
1692
1693 for ($xml) {
1694 # create single paragraphs (very hackish)
1695 s/(?<=\S)\n(?=\w)/ /g;
1696
1697 # compress some whitespace
1698 s/\s+\n/\n/g; # ws line-ends
1699 s/\n\n+/\n/g; # double lines
1700 s/^\n+//; # beginning lines
1701 s/\n+$//; # ending lines
1702 }
1703
1704 $xml
1705}
1706
1707no re 'eval';
1708
1709sub hintmode {
1710 $_[0]{hintmode} = $_[1] if @_ > 1;
1711 $_[0]{hintmode}
1712}
1713
1088=item $player->ext_reply ($msgid, $msgtype, %msg) 1714=item $player->ext_reply ($msgid, @msg)
1089 1715
1090Sends an ext reply to the player. 1716Sends an ext reply to the player.
1091 1717
1092=cut 1718=cut
1093 1719
1094sub ext_reply($$$%) { 1720sub ext_reply($$@) {
1095 my ($self, $id, %msg) = @_; 1721 my ($self, $id, @msg) = @_;
1096 1722
1097 $msg{msgid} = $id; 1723 $self->ns->ext_reply ($id, @msg)
1098
1099 $self->send ("ext " . cf::to_json \%msg);
1100} 1724}
1101 1725
1102package cf; 1726=item $player->ext_msg ($type, @msg)
1727
1728Sends an ext event to the client.
1729
1730=cut
1731
1732sub ext_msg($$@) {
1733 my ($self, $type, @msg) = @_;
1734
1735 $self->ns->ext_msg ($type, @msg);
1736}
1737
1738=head3 cf::region
1739
1740=over 4
1741
1742=cut
1743
1744package cf::region;
1745
1746=item cf::region::find_by_path $path
1747
1748Tries to decuce the likely region for a map knowing only its path.
1749
1750=cut
1751
1752sub find_by_path($) {
1753 my ($path) = @_;
1754
1755 my ($match, $specificity);
1756
1757 for my $region (list) {
1758 if ($region->{match} && $path =~ $region->{match}) {
1759 ($match, $specificity) = ($region, $region->specificity)
1760 if $region->specificity > $specificity;
1761 }
1762 }
1763
1764 $match
1765}
1103 1766
1104=back 1767=back
1105
1106 1768
1107=head3 cf::map 1769=head3 cf::map
1108 1770
1109=over 4 1771=over 4
1110 1772
… …
1114 1776
1115use Fcntl; 1777use Fcntl;
1116use Coro::AIO; 1778use Coro::AIO;
1117 1779
1118use overload 1780use overload
1119 '""' => \&as_string; 1781 '""' => \&as_string,
1782 fallback => 1;
1120 1783
1121our $MAX_RESET = 3600; 1784our $MAX_RESET = 3600;
1122our $DEFAULT_RESET = 3000; 1785our $DEFAULT_RESET = 3000;
1123 1786
1124sub generate_random_map { 1787sub generate_random_map {
1125 my ($self, $rmp) = @_; 1788 my ($self, $rmp) = @_;
1789
1790 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1126 1791
1127 # mit "rum" bekleckern, nicht 1792 # mit "rum" bekleckern, nicht
1128 $self->_create_random_map ( 1793 $self->_create_random_map (
1129 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1794 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1130 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1795 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
… …
1138 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1803 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1139 (cf::region::find $rmp->{region}), $rmp->{custom} 1804 (cf::region::find $rmp->{region}), $rmp->{custom}
1140 ) 1805 )
1141} 1806}
1142 1807
1808=item cf::map->register ($regex, $prio)
1809
1810Register a handler for the map path matching the given regex at the
1811givne priority (higher is better, built-in handlers have priority 0, the
1812default).
1813
1814=cut
1815
1143sub register { 1816sub register {
1144 my (undef, $regex) = @_; 1817 my (undef, $regex, $prio) = @_;
1145 my $pkg = caller; 1818 my $pkg = caller;
1146 1819
1147 no strict; 1820 no strict;
1148 push @{"$pkg\::ISA"}, __PACKAGE__; 1821 push @{"$pkg\::ISA"}, __PACKAGE__;
1149 1822
1150 $EXT_MAP{$pkg} = qr<$regex>; 1823 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1151} 1824}
1152 1825
1153# also paths starting with '/' 1826# also paths starting with '/'
1154$EXT_MAP{"cf::map"} = qr{^(?=/)}; 1827$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1828
1829sub thawer_merge {
1830 my ($self, $merge) = @_;
1831
1832 # we have to keep some variables in memory intact
1833 local $self->{path};
1834 local $self->{load_path};
1835
1836 $self->SUPER::thawer_merge ($merge);
1837}
1155 1838
1156sub normalise { 1839sub normalise {
1157 my ($path, $base) = @_; 1840 my ($path, $base) = @_;
1841
1842 $path = "$path"; # make sure its a string
1843
1844 $path =~ s/\.map$//;
1158 1845
1159 # map plan: 1846 # map plan:
1160 # 1847 #
1161 # /! non-realised random map exit (special hack!) 1848 # /! non-realised random map exit (special hack!)
1162 # {... are special paths that are not being touched 1849 # {... are special paths that are not being touched
… …
1190 1877
1191 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object 1878 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1192 1879
1193 $path = normalise $path, $base; 1880 $path = normalise $path, $base;
1194 1881
1195 for my $pkg (keys %EXT_MAP) { 1882 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1196 if ($path =~ $EXT_MAP{$pkg}) { 1883 if ($path =~ $EXT_MAP{$pkg}[1]) {
1197 my $self = bless cf::map::new, $pkg; 1884 my $self = bless cf::map::new, $pkg;
1198 $self->{path} = $path; $self->path ($path); 1885 $self->{path} = $path; $self->path ($path);
1199 $self->init; # pass $1 etc. 1886 $self->init; # pass $1 etc.
1200 return $self; 1887 return $self;
1201 } 1888 }
1202 } 1889 }
1203 1890
1204 Carp::carp "unable to resolve path '$path'."; 1891 Carp::cluck "unable to resolve path '$path' (base '$base').";
1205 () 1892 ()
1206} 1893}
1207 1894
1208sub init { 1895sub init {
1209 my ($self) = @_; 1896 my ($self) = @_;
… …
1220# the displayed name, this is a one way mapping 1907# the displayed name, this is a one way mapping
1221sub visible_name { 1908sub visible_name {
1222 &as_string 1909 &as_string
1223} 1910}
1224 1911
1225# escape the /'s in the path
1226sub _escaped_path {
1227 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1228
1229 $path
1230}
1231
1232# the original (read-only) location 1912# the original (read-only) location
1233sub load_path { 1913sub load_path {
1234 my ($self) = @_; 1914 my ($self) = @_;
1235 1915
1236 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1916 "$MAPDIR/$self->{path}.map"
1237} 1917}
1238 1918
1239# the temporary/swap location 1919# the temporary/swap location
1240sub save_path { 1920sub save_path {
1241 my ($self) = @_; 1921 my ($self) = @_;
1242 1922
1243 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $self->_escaped_path 1923 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1924 "$TMPDIR/$path.map"
1244} 1925}
1245 1926
1246# the unique path, undef == no special unique path 1927# the unique path, undef == no special unique path
1247sub uniq_path { 1928sub uniq_path {
1248 my ($self) = @_; 1929 my ($self) = @_;
1249 1930
1250 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path 1931 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1932 "$UNIQUEDIR/$path"
1251} 1933}
1252 1934
1253# and all this just because we cannot iterate over 1935# and all this just because we cannot iterate over
1254# all maps in C++... 1936# all maps in C++...
1255sub change_all_map_light { 1937sub change_all_map_light {
… …
1257 1939
1258 $_->change_map_light ($change) 1940 $_->change_map_light ($change)
1259 for grep $_->outdoor, values %cf::MAP; 1941 for grep $_->outdoor, values %cf::MAP;
1260} 1942}
1261 1943
1944sub decay_objects {
1945 my ($self) = @_;
1946
1947 return if $self->{deny_reset};
1948
1949 $self->do_decay_objects;
1950}
1951
1262sub unlink_save { 1952sub unlink_save {
1263 my ($self) = @_; 1953 my ($self) = @_;
1264 1954
1265 utf8::encode (my $save = $self->save_path); 1955 utf8::encode (my $save = $self->save_path);
1266 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save; 1956 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1267 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst"; 1957 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1268} 1958}
1269 1959
1270sub load_header_from($) { 1960sub load_header_from($) {
1271 my ($self, $path) = @_; 1961 my ($self, $path) = @_;
1272 1962
1273 utf8::encode $path; 1963 utf8::encode $path;
1274 aio_open $path, O_RDONLY, 0 1964 my $f = new_from_file cf::object::thawer $path
1275 or return; 1965 or return;
1276 1966
1277 $self->_load_header ($path) 1967 $self->_load_header ($f)
1278 or return; 1968 or return;
1279 1969
1970 local $MAP_LOADING{$self->{path}} = $self;
1971 $f->resolve_delayed_derefs;
1972
1280 $self->{load_path} = $path; 1973 $self->{load_path} = $path;
1281 1974
1282 1 1975 1
1283} 1976}
1284 1977
1285sub load_orig { 1978sub load_header_orig {
1286 my ($self) = @_; 1979 my ($self) = @_;
1287 1980
1288 $self->load_header_from ($self->load_path) 1981 $self->load_header_from ($self->load_path)
1289} 1982}
1290 1983
1291sub load_temp { 1984sub load_header_temp {
1292 my ($self) = @_; 1985 my ($self) = @_;
1293 1986
1294 $self->load_header_from ($self->save_path) 1987 $self->load_header_from ($self->save_path)
1988}
1989
1990sub prepare_temp {
1991 my ($self) = @_;
1992
1993 $self->last_access ((delete $self->{last_access})
1994 || $cf::RUNTIME); #d#
1995 # safety
1996 $self->{instantiate_time} = $cf::RUNTIME
1997 if $self->{instantiate_time} > $cf::RUNTIME;
1998}
1999
2000sub prepare_orig {
2001 my ($self) = @_;
2002
2003 $self->{load_original} = 1;
2004 $self->{instantiate_time} = $cf::RUNTIME;
2005 $self->last_access ($cf::RUNTIME);
2006 $self->instantiate;
1295} 2007}
1296 2008
1297sub load_header { 2009sub load_header {
1298 my ($self) = @_; 2010 my ($self) = @_;
1299 2011
1300 if ($self->load_temp) { 2012 if ($self->load_header_temp) {
1301 $self->last_access ((delete $self->{last_access}) 2013 $self->prepare_temp;
1302 || $cf::RUNTIME); #d#
1303 # safety
1304 $self->{instantiate_time} = $cf::RUNTIME
1305 if $self->{instantiate_time} > $cf::RUNTIME;
1306 } else { 2014 } else {
1307 $self->load_orig 2015 $self->load_header_orig
1308 or return; 2016 or return;
1309 2017 $self->prepare_orig;
1310 $self->{load_original} = 1;
1311 $self->{instantiate_time} = $cf::RUNTIME;
1312 $self->last_access ($cf::RUNTIME);
1313 $self->instantiate;
1314 } 2018 }
2019
2020 $self->{deny_reset} = 1
2021 if $self->no_reset;
2022
2023 $self->default_region (cf::region::find_by_path $self->{path})
2024 unless $self->default_region;
1315 2025
1316 1 2026 1
1317} 2027}
1318 2028
1319sub find; 2029sub find;
1320sub find { 2030sub find {
1321 my ($path, $origin) = @_; 2031 my ($path, $origin) = @_;
1322 2032
1323 $path = normalise $path, $origin && $origin->path; 2033 $path = normalise $path, $origin && $origin->path;
1324 2034
2035 cf::lock_wait "map_data:$path";#d#remove
1325 cf::lock_wait "map_find:$path"; 2036 cf::lock_wait "map_find:$path";
1326 2037
1327 $cf::MAP{$path} || do { 2038 $cf::MAP{$path} || do {
2039 my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1328 my $guard = cf::lock_acquire "map_find:$path"; 2040 my $guard2 = cf::lock_acquire "map_find:$path";
2041
1329 my $map = new_from_path cf::map $path 2042 my $map = new_from_path cf::map $path
1330 or return; 2043 or return;
1331 2044
1332 $map->{last_save} = $cf::RUNTIME; 2045 $map->{last_save} = $cf::RUNTIME;
1333 2046
1334 $map->load_header 2047 $map->load_header
1335 or return; 2048 or return;
1336 2049
1337 if ($map->should_reset) { 2050 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
2051 # doing this can freeze the server in a sync job, obviously
2052 #$cf::WAIT_FOR_TICK->wait;
2053 undef $guard2;
2054 undef $guard1;
1338 $map->reset; 2055 $map->reset;
1339 undef $guard;
1340 $map = find $path 2056 return find $path;
1341 or return;
1342 } 2057 }
1343 2058
1344 $cf::MAP{$path} = $map 2059 $cf::MAP{$path} = $map
1345 } 2060 }
1346} 2061}
2062
2063sub pre_load { }
2064sub post_load { }
1347 2065
1348sub load { 2066sub load {
1349 my ($self) = @_; 2067 my ($self) = @_;
1350 2068
2069 local $self->{deny_reset} = 1; # loading can take a long time
2070
1351 my $path = $self->{path}; 2071 my $path = $self->{path};
2072
2073 {
1352 my $guard = cf::lock_acquire "map_load:$path"; 2074 my $guard = cf::lock_acquire "map_data:$path";
1353 2075
2076 return unless $self->valid;
1354 return if $self->in_memory != cf::MAP_SWAPPED; 2077 return unless $self->in_memory == cf::MAP_SWAPPED;
1355 2078
1356 $self->in_memory (cf::MAP_LOADING); 2079 $self->in_memory (cf::MAP_LOADING);
1357 2080
1358 $self->alloc; 2081 $self->alloc;
1359 $self->_load_objects ($self->{load_path}, 1) 2082
2083 $self->pre_load;
2084 cf::cede_to_tick;
2085
2086 my $f = new_from_file cf::object::thawer $self->{load_path};
2087 $f->skip_block;
2088 $self->_load_objects ($f)
1360 or return; 2089 or return;
1361 2090
1362 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2091 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1363 if delete $self->{load_original}; 2092 if delete $self->{load_original};
1364 2093
1365 if (my $uniq = $self->uniq_path) { 2094 if (my $uniq = $self->uniq_path) {
1366 utf8::encode $uniq; 2095 utf8::encode $uniq;
1367 if (aio_open $uniq, O_RDONLY, 0) { 2096 unless (aio_stat $uniq) {
2097 if (my $f = new_from_file cf::object::thawer $uniq) {
1368 $self->clear_unique_items; 2098 $self->clear_unique_items;
1369 $self->_load_objects ($uniq, 0); 2099 $self->_load_objects ($f);
2100 $f->resolve_delayed_derefs;
2101 }
1370 } 2102 }
1371 } 2103 }
1372 2104
1373 Coro::cede; 2105 $f->resolve_delayed_derefs;
1374 2106
2107 cf::cede_to_tick;
1375 # now do the right thing for maps 2108 # now do the right thing for maps
1376 $self->link_multipart_objects; 2109 $self->link_multipart_objects;
1377
1378 unless ($self->{deny_activate}) {
1379 $self->decay_objects;
1380 $self->fix_auto_apply;
1381 $self->update_buttons;
1382 Coro::cede;
1383 $self->set_darkness_map;
1384 $self->difficulty ($self->estimate_difficulty) 2110 $self->difficulty ($self->estimate_difficulty)
1385 unless $self->difficulty; 2111 unless $self->difficulty;
1386 Coro::cede; 2112 cf::cede_to_tick;
2113
2114 unless ($self->{deny_activate}) {
2115 $self->decay_objects;
2116 $self->fix_auto_apply;
2117 $self->update_buttons;
2118 cf::cede_to_tick;
2119 $self->set_darkness_map;
2120 cf::cede_to_tick;
1387 $self->activate; 2121 $self->activate;
1388 } 2122 }
1389 2123
2124 $self->{last_save} = $cf::RUNTIME;
2125 $self->last_access ($cf::RUNTIME);
2126
1390 $self->in_memory (cf::MAP_IN_MEMORY); 2127 $self->in_memory (cf::MAP_ACTIVE);
2128 }
2129
2130 $self->post_load;
1391} 2131}
1392 2132
1393sub customise_for { 2133sub customise_for {
1394 my ($self, $ob) = @_; 2134 my ($self, $ob) = @_;
1395 2135
1396 return find "~" . $ob->name . "/" . $self->{path} 2136 return find "~" . $ob->name . "/" . $self->{path}
1397 if $self->per_player; 2137 if $self->per_player;
1398 2138
2139# return find "?party/" . $ob->name . "/" . $self->{path}
2140# if $self->per_party;
2141
1399 $self 2142 $self
1400} 2143}
1401 2144
1402# find and load all maps in the 3x3 area around a map 2145# find and load all maps in the 3x3 area around a map
1403sub load_diag { 2146sub load_neighbours {
1404 my ($map) = @_; 2147 my ($map) = @_;
1405 2148
1406 my @diag; # diagonal neighbours 2149 my @neigh; # diagonal neighbours
1407 2150
1408 for (0 .. 3) { 2151 for (0 .. 3) {
1409 my $neigh = $map->tile_path ($_) 2152 my $neigh = $map->tile_path ($_)
1410 or next; 2153 or next;
1411 $neigh = find $neigh, $map 2154 $neigh = find $neigh, $map
1412 or next; 2155 or next;
1413 $neigh->load; 2156 $neigh->load;
1414 2157
2158 push @neigh,
1415 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2159 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1416 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2160 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1417 } 2161 }
1418 2162
1419 for (@diag) { 2163 for (grep defined $_->[0], @neigh) {
2164 my ($path, $origin) = @$_;
1420 my $neigh = find @$_ 2165 my $neigh = find $path, $origin
1421 or next; 2166 or next;
1422 $neigh->load; 2167 $neigh->load;
1423 } 2168 }
1424} 2169}
1425 2170
… …
1430} 2175}
1431 2176
1432sub do_load_sync { 2177sub do_load_sync {
1433 my ($map) = @_; 2178 my ($map) = @_;
1434 2179
2180 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2181 if $Coro::current == $Coro::main;
2182
1435 cf::sync_job { $map->load }; 2183 cf::sync_job { $map->load };
1436} 2184}
1437 2185
1438our %MAP_PREFETCH; 2186our %MAP_PREFETCH;
1439our $MAP_PREFETCHER = Coro::async { 2187our $MAP_PREFETCHER = undef;
1440 while () {
1441 for my $path (keys %MAP_PREFETCH) {
1442 my $map = find $path
1443 or next;
1444 $map->load;
1445
1446 delete $MAP_PREFETCH{$path};
1447 }
1448 Coro::schedule;
1449 }
1450};
1451 2188
1452sub find_async { 2189sub find_async {
1453 my ($path, $origin) = @_; 2190 my ($path, $origin, $load) = @_;
1454 2191
1455 $path = normalise $path, $origin && $origin->{path}; 2192 $path = normalise $path, $origin && $origin->{path};
1456 2193
1457 if (my $map = $cf::MAP{$path}) { 2194 if (my $map = $cf::MAP{$path}) {
1458 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2195 return $map if !$load || $map->in_memory == cf::MAP_ACTIVE;
2196 }
2197
2198 $MAP_PREFETCH{$path} |= $load;
2199
2200 $MAP_PREFETCHER ||= cf::async {
2201 $Coro::current->{desc} = "map prefetcher";
2202
2203 while (%MAP_PREFETCH) {
2204 while (my ($k, $v) = each %MAP_PREFETCH) {
2205 if (my $map = find $k) {
2206 $map->load if $v;
2207 }
2208
2209 delete $MAP_PREFETCH{$k};
2210 }
2211 }
2212 undef $MAP_PREFETCHER;
1459 } 2213 };
1460
1461 $MAP_PREFETCH{$path} = 0;
1462 $MAP_PREFETCHER->ready; 2214 $MAP_PREFETCHER->prio (6);
1463 2215
1464 () 2216 ()
1465} 2217}
1466 2218
1467sub save { 2219sub save {
1468 my ($self) = @_; 2220 my ($self) = @_;
1469 2221
1470 my $lock = cf::lock_acquire "map_data:" . $self->path; 2222 my $lock = cf::lock_acquire "map_data:$self->{path}";
1471 2223
1472 $self->{last_save} = $cf::RUNTIME; 2224 $self->{last_save} = $cf::RUNTIME;
1473 2225
1474 return unless $self->dirty; 2226 return unless $self->dirty;
1475 2227
… …
1481 return if $self->{deny_save}; 2233 return if $self->{deny_save};
1482 2234
1483 local $self->{last_access} = $self->last_access;#d# 2235 local $self->{last_access} = $self->last_access;#d#
1484 2236
1485 cf::async { 2237 cf::async {
2238 $Coro::current->{desc} = "map player save";
1486 $_->contr->save for $self->players; 2239 $_->contr->save for $self->players;
1487 }; 2240 };
2241
2242 cf::get_slot 0.02;
1488 2243
1489 if ($uniq) { 2244 if ($uniq) {
1490 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2245 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1491 $self->_save_objects ($uniq, cf::IO_UNIQUES); 2246 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1492 } else { 2247 } else {
… …
1498 my ($self) = @_; 2253 my ($self) = @_;
1499 2254
1500 # save first because save cedes 2255 # save first because save cedes
1501 $self->save; 2256 $self->save;
1502 2257
1503 my $lock = cf::lock_acquire "map_data:" . $self->path; 2258 my $lock = cf::lock_acquire "map_data:$self->{path}";
1504 2259
1505 return if $self->players; 2260 return if $self->players;
1506 return if $self->in_memory != cf::MAP_IN_MEMORY; 2261 return if $self->in_memory != cf::MAP_ACTIVE;
1507 return if $self->{deny_save}; 2262 return if $self->{deny_save};
1508 2263
2264 $self->in_memory (cf::MAP_SWAPPED);
2265
2266 $self->deactivate;
2267 $_->clear_links_to ($self) for values %cf::MAP;
1509 $self->clear; 2268 $self->clear;
1510 $self->in_memory (cf::MAP_SWAPPED);
1511} 2269}
1512 2270
1513sub reset_at { 2271sub reset_at {
1514 my ($self) = @_; 2272 my ($self) = @_;
1515 2273
1516 # TODO: safety, remove and allow resettable per-player maps 2274 # TODO: safety, remove and allow resettable per-player maps
1517 return 1e99 if $self->isa ("ext::map_per_player");
1518 return 1e99 if $self->{deny_reset}; 2275 return 1e99 if $self->{deny_reset};
1519 2276
1520 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2277 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1521 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2278 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1522 2279
… …
1527 my ($self) = @_; 2284 my ($self) = @_;
1528 2285
1529 $self->reset_at <= $cf::RUNTIME 2286 $self->reset_at <= $cf::RUNTIME
1530} 2287}
1531 2288
1532sub rename {
1533 my ($self, $new_path) = @_;
1534
1535 normalise $new_path;
1536
1537 $self->unlink_save;
1538
1539 delete $cf::MAP{$self->path};
1540 $self->{path} = $new_path; $self->path ($self->{path});
1541 $cf::MAP{$self->path} = $self;
1542
1543 $self->save;
1544}
1545
1546sub reset { 2289sub reset {
1547 my ($self) = @_; 2290 my ($self) = @_;
1548 2291
1549 my $lock = cf::lock_acquire "map_data:" . $self->path; 2292 my $lock = cf::lock_acquire "map_data:$self->{path}";
1550 2293
1551 return if $self->players; 2294 return if $self->players;
1552 return if $self->isa ("ext::map_per_player");#d#
1553 2295
1554 warn "resetting map ", $self->path;#d# 2296 warn "resetting map ", $self->path;
2297
2298 $self->in_memory (cf::MAP_SWAPPED);
2299
2300 # need to save uniques path
2301 unless ($self->{deny_save}) {
2302 my $uniq = $self->uniq_path; utf8::encode $uniq;
2303
2304 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2305 if $uniq;
2306 }
1555 2307
1556 delete $cf::MAP{$self->path}; 2308 delete $cf::MAP{$self->path};
1557 2309
2310 $self->deactivate;
1558 $_->clear_links_to ($self) for values %cf::MAP; 2311 $_->clear_links_to ($self) for values %cf::MAP;
2312 $self->clear;
1559 2313
1560 $self->unlink_save; 2314 $self->unlink_save;
1561 $self->destroy; 2315 $self->destroy;
1562} 2316}
1563 2317
1564my $nuke_counter = "aaaa"; 2318my $nuke_counter = "aaaa";
1565 2319
1566sub nuke { 2320sub nuke {
1567 my ($self) = @_; 2321 my ($self) = @_;
1568 2322
2323 {
2324 my $lock = cf::lock_acquire "map_data:$self->{path}";
2325
2326 delete $cf::MAP{$self->path};
2327
2328 $self->unlink_save;
2329
2330 bless $self, "cf::map";
2331 delete $self->{deny_reset};
1569 $self->{deny_save} = 1; 2332 $self->{deny_save} = 1;
1570 $self->reset_timeout (1); 2333 $self->reset_timeout (1);
1571 $self->rename ("{nuke}/" . ($nuke_counter++)); 2334 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2335
2336 $cf::MAP{$self->path} = $self;
2337 }
2338
1572 $self->reset; # polite request, might not happen 2339 $self->reset; # polite request, might not happen
2340}
2341
2342=item $maps = cf::map::tmp_maps
2343
2344Returns an arrayref with all map paths of currently instantiated and saved
2345maps. May block.
2346
2347=cut
2348
2349sub tmp_maps() {
2350 [
2351 map {
2352 utf8::decode $_;
2353 /\.map$/
2354 ? normalise $_
2355 : ()
2356 } @{ aio_readdir $TMPDIR or [] }
2357 ]
2358}
2359
2360=item $maps = cf::map::random_maps
2361
2362Returns an arrayref with all map paths of currently instantiated and saved
2363random maps. May block.
2364
2365=cut
2366
2367sub random_maps() {
2368 [
2369 map {
2370 utf8::decode $_;
2371 /\.map$/
2372 ? normalise "?random/$_"
2373 : ()
2374 } @{ aio_readdir $RANDOMDIR or [] }
2375 ]
1573} 2376}
1574 2377
1575=item cf::map::unique_maps 2378=item cf::map::unique_maps
1576 2379
1577Returns an arrayref of paths of all shared maps that have 2380Returns an arrayref of paths of all shared maps that have
1578instantiated unique items. May block. 2381instantiated unique items. May block.
1579 2382
1580=cut 2383=cut
1581 2384
1582sub unique_maps() { 2385sub unique_maps() {
1583 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2386 [
1584 or return; 2387 map {
1585
1586 my @paths;
1587
1588 for (@$files) {
1589 utf8::decode $_; 2388 utf8::decode $_;
1590 next if /\.pst$/; 2389 s/\.map$//; # TODO future compatibility hack
1591 next unless /^$PATH_SEP/o; 2390 /\.pst$/ || !/^$PATH_SEP/o # TODO unique maps apparebntly lack the .map suffix :/
1592 2391 ? ()
1593 push @paths, $_; 2392 : normalise $_
2393 } @{ aio_readdir $UNIQUEDIR or [] }
1594 } 2394 ]
1595
1596 \@paths
1597} 2395}
1598
1599package cf;
1600 2396
1601=back 2397=back
1602 2398
1603=head3 cf::object 2399=head3 cf::object
1604 2400
… …
1608 2404
1609=over 4 2405=over 4
1610 2406
1611=item $ob->inv_recursive 2407=item $ob->inv_recursive
1612 2408
1613Returns the inventory of the object _and_ their inventories, recursively. 2409Returns the inventory of the object I<and> their inventories, recursively,
2410but I<not> the object itself.
1614 2411
1615=cut 2412=cut
1616 2413
1617sub inv_recursive_; 2414sub inv_recursive_;
1618sub inv_recursive_ { 2415sub inv_recursive_ {
… …
1621 2418
1622sub inv_recursive { 2419sub inv_recursive {
1623 inv_recursive_ inv $_[0] 2420 inv_recursive_ inv $_[0]
1624} 2421}
1625 2422
2423=item $ref = $ob->ref
2424
2425Creates and returns a persistent reference to an object that can be stored as a string.
2426
2427=item $ob = cf::object::deref ($refstring)
2428
2429returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2430even if the object actually exists. May block.
2431
2432=cut
2433
2434sub deref {
2435 my ($ref) = @_;
2436
2437 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2438 my ($uuid, $name) = ($1, $2);
2439 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2440 or return;
2441 $pl->ob->uuid eq $uuid
2442 or return;
2443
2444 $pl->ob
2445 } else {
2446 warn "$ref: cannot resolve object reference\n";
2447 undef
2448 }
2449}
2450
1626package cf; 2451package cf;
1627 2452
1628=back 2453=back
1629 2454
1630=head3 cf::object::player 2455=head3 cf::object::player
… …
1636Sends a message to the player, as if the npc C<$npc> replied. C<$npc> 2461Sends a message to the player, as if the npc C<$npc> replied. C<$npc>
1637can be C<undef>. Does the right thing when the player is currently in a 2462can be C<undef>. Does the right thing when the player is currently in a
1638dialogue with the given NPC character. 2463dialogue with the given NPC character.
1639 2464
1640=cut 2465=cut
2466
2467our $SAY_CHANNEL = {
2468 id => "say",
2469 title => "Map",
2470 reply => "say ",
2471 tooltip => "Things said to and replied from npcs near you and other players on the same map only.",
2472};
2473
2474our $CHAT_CHANNEL = {
2475 id => "chat",
2476 title => "Chat",
2477 reply => "chat ",
2478 tooltip => "Player chat and shouts, global to the server.",
2479};
1641 2480
1642# rough implementation of a future "reply" method that works 2481# rough implementation of a future "reply" method that works
1643# with dialog boxes. 2482# with dialog boxes.
1644#TODO: the first argument must go, split into a $npc->reply_to ( method 2483#TODO: the first argument must go, split into a $npc->reply_to ( method
1645sub cf::object::player::reply($$$;$) { 2484sub cf::object::player::reply($$$;$) {
… …
1647 2486
1648 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2487 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1649 2488
1650 if ($self->{record_replies}) { 2489 if ($self->{record_replies}) {
1651 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2490 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2491
1652 } else { 2492 } else {
2493 my $pl = $self->contr;
2494
2495 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2496 my $dialog = $pl->{npc_dialog};
2497 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2498
2499 } else {
1653 $msg = $npc->name . " says: $msg" if $npc; 2500 $msg = $npc->name . " says: $msg" if $npc;
1654 $self->message ($msg, $flags); 2501 $self->send_msg ($SAY_CHANNEL => $msg, $flags);
2502 }
1655 } 2503 }
2504}
2505
2506=item $object->send_msg ($channel, $msg, $color, [extra...])
2507
2508=cut
2509
2510sub cf::object::send_msg {
2511 my $pl = shift->contr
2512 or return;
2513 $pl->send_msg (@_);
1656} 2514}
1657 2515
1658=item $player_object->may ("access") 2516=item $player_object->may ("access")
1659 2517
1660Returns wether the given player is authorized to access resource "access" 2518Returns wether the given player is authorized to access resource "access"
… …
1692=cut 2550=cut
1693 2551
1694sub link_map { 2552sub link_map {
1695 unless ($LINK_MAP) { 2553 unless ($LINK_MAP) {
1696 $LINK_MAP = cf::map::find "{link}" 2554 $LINK_MAP = cf::map::find "{link}"
1697 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 2555 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1698 $LINK_MAP->load; 2556 $LINK_MAP->load;
1699 } 2557 }
1700 2558
1701 $LINK_MAP 2559 $LINK_MAP
1702} 2560}
… …
1707 $self->deactivate_recursive; 2565 $self->deactivate_recursive;
1708 2566
1709 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2567 return if UNIVERSAL::isa $self->map, "ext::map_link";
1710 2568
1711 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2569 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1712 if $self->map; 2570 if $self->map && $self->map->{path} ne "{link}";
1713 2571
1714 $self->enter_map ($LINK_MAP || link_map, 20, 20); 2572 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1715} 2573}
1716 2574
1717sub cf::object::player::leave_link { 2575sub cf::object::player::leave_link {
1718 my ($self, $map, $x, $y) = @_; 2576 my ($self, $map, $x, $y) = @_;
2577
2578 return unless $self->contr->active;
1719 2579
1720 my $link_pos = delete $self->{_link_pos}; 2580 my $link_pos = delete $self->{_link_pos};
1721 2581
1722 unless ($map) { 2582 unless ($map) {
1723 # restore original map position 2583 # restore original map position
… …
1737 # use -1 or undef as default coordinates, not 0, 0 2597 # use -1 or undef as default coordinates, not 0, 0
1738 ($x, $y) = ($map->enter_x, $map->enter_y) 2598 ($x, $y) = ($map->enter_x, $map->enter_y)
1739 if $x <=0 && $y <= 0; 2599 if $x <=0 && $y <= 0;
1740 2600
1741 $map->load; 2601 $map->load;
1742 $map->load_diag; 2602 $map->load_neighbours;
1743 2603
1744 return unless $self->contr->active; 2604 return unless $self->contr->active;
1745 $self->activate_recursive; 2605 $self->activate_recursive;
2606
2607 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1746 $self->enter_map ($map, $x, $y); 2608 $self->enter_map ($map, $x, $y);
1747} 2609}
1748 2610
1749cf::player->attach ( 2611=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1750 on_logout => sub {
1751 my ($pl) = @_;
1752 2612
1753 # abort map switching before logout 2613Moves the player to the given map-path and coordinates by first freezing
1754 if ($pl->ob->{_link_pos}) { 2614her, loading and preparing them map, calling the provided $check callback
1755 cf::sync_job { 2615that has to return the map if sucecssful, and then unfreezes the player on
1756 $pl->ob->leave_link 2616the new (success) or old (failed) map position. In either case, $done will
1757 }; 2617be called at the end of this process.
1758 }
1759 },
1760 on_login => sub {
1761 my ($pl) = @_;
1762 2618
1763 # try to abort aborted map switching on player login :)
1764 # should happen only on crashes
1765 if ($pl->ob->{_link_pos}) {
1766 $pl->ob->enter_link;
1767 (async {
1768 # we need this sleep as the login has a concurrent enter_exit running
1769 # and this sleep increases chances of the player not ending up in scorn
1770 $pl->ob->reply (undef,
1771 "There was an internal problem at your last logout, "
1772 . "the server will try to bring you to your intended destination in a second.",
1773 cf::NDI_RED);
1774 Coro::Timer::sleep 1;
1775 $pl->ob->leave_link;
1776 })->prio (2);
1777 }
1778 },
1779);
1780
1781=item $player_object->goto ($path, $x, $y)
1782
1783=cut 2619=cut
2620
2621our $GOTOGEN;
1784 2622
1785sub cf::object::player::goto { 2623sub cf::object::player::goto {
1786 my ($self, $path, $x, $y) = @_; 2624 my ($self, $path, $x, $y, $check, $done) = @_;
2625
2626 # do generation counting so two concurrent goto's will be executed in-order
2627 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1787 2628
1788 $self->enter_link; 2629 $self->enter_link;
1789 2630
1790 (async { 2631 (async {
1791 my $map = cf::map::find $path; 2632 $Coro::current->{desc} = "player::goto $path $x $y";
2633
2634 # *tag paths override both path and x|y
2635 if ($path =~ /^\*(.*)$/) {
2636 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2637 my $ob = $obs[rand @obs];
2638
2639 # see if we actually can go there
2640 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2641 $ob = $obs[rand @obs];
2642 } else {
2643 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2644 }
2645 # else put us there anyways for now #d#
2646
2647 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2648 } else {
2649 ($path, $x, $y) = (undef, undef, undef);
2650 }
2651 }
2652
2653 my $map = eval {
2654 my $map = defined $path ? cf::map::find $path : undef;
2655
2656 if ($map) {
1792 $map = $map->customise_for ($self) if $map; 2657 $map = $map->customise_for ($self);
1793 2658 $map = $check->($map) if $check && $map;
1794# warn "entering ", $map->path, " at ($x, $y)\n" 2659 } else {
1795# if $map;
1796
1797 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2660 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2661 }
1798 2662
2663 $map
2664 };
2665
2666 if ($@) {
2667 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2668 LOG llevError | logBacktrace, Carp::longmess $@;
2669 }
2670
2671 if ($gen == $self->{_goto_generation}) {
2672 delete $self->{_goto_generation};
1799 $self->leave_link ($map, $x, $y); 2673 $self->leave_link ($map, $x, $y);
2674 }
2675
2676 $done->() if $done;
1800 })->prio (1); 2677 })->prio (1);
1801} 2678}
1802 2679
1803=item $player_object->enter_exit ($exit_object) 2680=item $player_object->enter_exit ($exit_object)
1804 2681
… …
1806 2683
1807sub parse_random_map_params { 2684sub parse_random_map_params {
1808 my ($spec) = @_; 2685 my ($spec) = @_;
1809 2686
1810 my $rmp = { # defaults 2687 my $rmp = { # defaults
1811 xsize => 10, 2688 xsize => (cf::rndm 15, 40),
1812 ysize => 10, 2689 ysize => (cf::rndm 15, 40),
2690 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2691 #layout => string,
1813 }; 2692 };
1814 2693
1815 for (split /\n/, $spec) { 2694 for (split /\n/, $spec) {
1816 my ($k, $v) = split /\s+/, $_, 2; 2695 my ($k, $v) = split /\s+/, $_, 2;
1817 2696
… …
1829 # that depends on the exit object 2708 # that depends on the exit object
1830 2709
1831 my $rmp = parse_random_map_params $exit->msg; 2710 my $rmp = parse_random_map_params $exit->msg;
1832 2711
1833 if ($exit->map) { 2712 if ($exit->map) {
1834 $rmp->{region} = $exit->map->region_name; 2713 $rmp->{region} = $exit->region->name;
1835 $rmp->{origin_map} = $exit->map->path; 2714 $rmp->{origin_map} = $exit->map->path;
1836 $rmp->{origin_x} = $exit->x; 2715 $rmp->{origin_x} = $exit->x;
1837 $rmp->{origin_y} = $exit->y; 2716 $rmp->{origin_y} = $exit->y;
2717
2718 $exit->map->touch;
1838 } 2719 }
1839 2720
1840 $rmp->{random_seed} ||= $exit->random_seed; 2721 $rmp->{random_seed} ||= $exit->random_seed;
1841 2722
1842 my $data = cf::to_json $rmp; 2723 my $data = JSON::XS->new->utf8->pretty->canonical->encode ($rmp);
1843 my $md5 = Digest::MD5::md5_hex $data; 2724 my $md5 = Digest::MD5::md5_hex $data;
2725 my $meta = "$RANDOMDIR/$md5.meta";
1844 2726
1845 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2727 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1846 aio_write $fh, 0, (length $data), $data, 0; 2728 aio_write $fh, 0, (length $data), $data, 0;
2729 undef $fh;
2730 aio_rename "$meta~", $meta;
1847 2731
2732 my $slaying = "?random/$md5";
2733
2734 if ($exit->valid) {
1848 $exit->slaying ("?random/$md5"); 2735 $exit->slaying ("?random/$md5");
1849 $exit->msg (undef); 2736 $exit->msg (undef);
2737 }
1850 } 2738 }
1851} 2739}
1852 2740
1853sub cf::object::player::enter_exit { 2741sub cf::object::player::enter_exit {
1854 my ($self, $exit) = @_; 2742 my ($self, $exit) = @_;
… …
1856 return unless $self->type == cf::PLAYER; 2744 return unless $self->type == cf::PLAYER;
1857 2745
1858 $self->enter_link; 2746 $self->enter_link;
1859 2747
1860 (async { 2748 (async {
1861 $self->deactivate_recursive; # just to be sure 2749 $Coro::current->{desc} = "enter_exit";
2750
1862 unless (eval { 2751 unless (eval {
2752 $self->deactivate_recursive; # just to be sure
2753
2754 # random map handling
2755 {
2756 my $guard = cf::lock_acquire "exit_prepare:$exit";
2757
1863 prepare_random_map $exit 2758 prepare_random_map $exit
1864 if $exit->slaying eq "/!"; 2759 if $exit->slaying eq "/!";
2760 }
1865 2761
1866 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path; 2762 my $map = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1867 $self->goto ($path, $exit->stats->hp, $exit->stats->sp); 2763 my $x = $exit->stats->hp;
2764 my $y = $exit->stats->sp;
1868 2765
2766 $self->goto ($map, $x, $y);
2767
2768 # if exit is damned, update players death & WoR home-position
2769 $self->contr->savebed ($map, $x, $y)
2770 if $exit->flag (cf::FLAG_DAMNED);
2771
1869 1; 2772 1
1870 }) { 2773 }) {
1871 $self->message ("Something went wrong deep within the crossfire server. " 2774 $self->message ("Something went wrong deep within the crossfire server. "
1872 . "I'll try to bring you back to the map you were before. " 2775 . "I'll try to bring you back to the map you were before. "
1873 . "Please report this to the dungeon master!", 2776 . "Please report this to the dungeon master!",
1874 cf::NDI_UNIQUE | cf::NDI_RED); 2777 cf::NDI_UNIQUE | cf::NDI_RED);
1875 2778
1876 warn "ERROR in enter_exit: $@"; 2779 warn "ERROR in enter_exit: $@";
1877 $self->leave_link; 2780 $self->leave_link;
1878 } 2781 }
1879 })->prio (1); 2782 })->prio (1);
… …
1892 2795
1893sub cf::client::send_drawinfo { 2796sub cf::client::send_drawinfo {
1894 my ($self, $text, $flags) = @_; 2797 my ($self, $text, $flags) = @_;
1895 2798
1896 utf8::encode $text; 2799 utf8::encode $text;
1897 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2800 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1898} 2801}
1899 2802
2803=item $client->send_msg ($channel, $msg, $color, [extra...])
2804
2805Send a drawinfo or msg packet to the client, formatting the msg for the
2806client if neccessary. C<$type> should be a string identifying the type of
2807the message, with C<log> being the default. If C<$color> is negative, suppress
2808the message unless the client supports the msg packet.
2809
2810=cut
2811
2812# non-persistent channels (usually the info channel)
2813our %CHANNEL = (
2814 "c/identify" => {
2815 id => "infobox",
2816 title => "Identify",
2817 reply => undef,
2818 tooltip => "Items recently identified",
2819 },
2820 "c/examine" => {
2821 id => "infobox",
2822 title => "Examine",
2823 reply => undef,
2824 tooltip => "Signs and other items you examined",
2825 },
2826 "c/book" => {
2827 id => "infobox",
2828 title => "Book",
2829 reply => undef,
2830 tooltip => "The contents of a note or book",
2831 },
2832 "c/lookat" => {
2833 id => "infobox",
2834 title => "Look",
2835 reply => undef,
2836 tooltip => "What you saw there",
2837 },
2838 "c/who" => {
2839 id => "infobox",
2840 title => "Players",
2841 reply => undef,
2842 tooltip => "Shows players who are currently online",
2843 },
2844 "c/body" => {
2845 id => "infobox",
2846 title => "Body Parts",
2847 reply => undef,
2848 tooltip => "Shows which body parts you posess and are available",
2849 },
2850 "c/uptime" => {
2851 id => "infobox",
2852 title => "Uptime",
2853 reply => undef,
2854 tooltip => "How long the server has been running since last restart",
2855 },
2856 "c/mapinfo" => {
2857 id => "infobox",
2858 title => "Map Info",
2859 reply => undef,
2860 tooltip => "Information related to the maps",
2861 },
2862 "c/party" => {
2863 id => "party",
2864 title => "Party",
2865 reply => "gsay ",
2866 tooltip => "Messages and chat related to your party",
2867 },
2868);
2869
2870sub cf::client::send_msg {
2871 my ($self, $channel, $msg, $color, @extra) = @_;
2872
2873 $msg = $self->pl->expand_cfpod ($msg);
2874
2875 $color &= cf::NDI_CLIENT_MASK; # just in case...
2876
2877 # check predefined channels, for the benefit of C
2878 if ($CHANNEL{$channel}) {
2879 $channel = $CHANNEL{$channel};
2880
2881 $self->ext_msg (channel_info => $channel)
2882 if $self->can_msg;
2883
2884 $channel = $channel->{id};
2885
2886 } elsif (ref $channel) {
2887 # send meta info to client, if not yet sent
2888 unless (exists $self->{channel}{$channel->{id}}) {
2889 $self->{channel}{$channel->{id}} = $channel;
2890 $self->ext_msg (channel_info => $channel)
2891 if $self->can_msg;
2892 }
2893
2894 $channel = $channel->{id};
2895 }
2896
2897 return unless @extra || length $msg;
2898
2899 if ($self->can_msg) {
2900 # default colour, mask it out
2901 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2902 if $color & cf::NDI_DEF;
2903
2904 $self->send_packet ("msg " . $self->{json_coder}->encode (
2905 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2906 } else {
2907 if ($color >= 0) {
2908 # replace some tags by gcfclient-compatible ones
2909 for ($msg) {
2910 1 while
2911 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2912 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2913 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2914 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2915 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2916 }
2917
2918 $color &= cf::NDI_COLOR_MASK;
2919
2920 utf8::encode $msg;
2921
2922 if (0 && $msg =~ /\[/) {
2923 # COMMAND/INFO
2924 $self->send_packet ("drawextinfo $color 10 8 $msg")
2925 } else {
2926 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2927 $self->send_packet ("drawinfo $color $msg")
2928 }
2929 }
2930 }
2931}
2932
2933=item $client->ext_msg ($type, @msg)
2934
2935Sends an ext event to the client.
2936
2937=cut
2938
2939sub cf::client::ext_msg($$@) {
2940 my ($self, $type, @msg) = @_;
2941
2942 if ($self->extcmd == 2) {
2943 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2944 } elsif ($self->extcmd == 1) { # TODO: remove
2945 push @msg, msgtype => "event_$type";
2946 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2947 }
2948}
2949
2950=item $client->ext_reply ($msgid, @msg)
2951
2952Sends an ext reply to the client.
2953
2954=cut
2955
2956sub cf::client::ext_reply($$@) {
2957 my ($self, $id, @msg) = @_;
2958
2959 if ($self->extcmd == 2) {
2960 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2961 } elsif ($self->extcmd == 1) {
2962 #TODO: version 1, remove
2963 unshift @msg, msgtype => "reply", msgid => $id;
2964 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2965 }
2966}
1900 2967
1901=item $success = $client->query ($flags, "text", \&cb) 2968=item $success = $client->query ($flags, "text", \&cb)
1902 2969
1903Queues a query to the client, calling the given callback with 2970Queues a query to the client, calling the given callback with
1904the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2971the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1905C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2972C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1906 2973
1907Queries can fail, so check the return code. Or don't, as queries will become 2974Queries can fail, so check the return code. Or don't, as queries will
1908reliable at some point in the future. 2975become reliable at some point in the future.
1909 2976
1910=cut 2977=cut
1911 2978
1912sub cf::client::query { 2979sub cf::client::query {
1913 my ($self, $flags, $text, $cb) = @_; 2980 my ($self, $flags, $text, $cb) = @_;
… …
1921 utf8::encode $text; 2988 utf8::encode $text;
1922 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2989 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1923 2990
1924 $self->send_packet ($self->{query_queue}[0][0]) 2991 $self->send_packet ($self->{query_queue}[0][0])
1925 if @{ $self->{query_queue} } == 1; 2992 if @{ $self->{query_queue} } == 1;
2993
2994 1
1926} 2995}
1927 2996
1928cf::client->attach ( 2997cf::client->attach (
2998 on_connect => sub {
2999 my ($ns) = @_;
3000
3001 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
3002 },
1929 on_reply => sub { 3003 on_reply => sub {
1930 my ($ns, $msg) = @_; 3004 my ($ns, $msg) = @_;
1931 3005
1932 # this weird shuffling is so that direct followup queries 3006 # this weird shuffling is so that direct followup queries
1933 # get handled first 3007 # get handled first
1934 my $queue = delete $ns->{query_queue} 3008 my $queue = delete $ns->{query_queue}
1935 or return; # be conservative, not sure how that can happen, but we saw a crash here 3009 or return; # be conservative, not sure how that can happen, but we saw a crash here
1936 3010
1937 (shift @$queue)->[1]->($msg); 3011 (shift @$queue)->[1]->($msg);
3012 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1938 3013
1939 push @{ $ns->{query_queue} }, @$queue; 3014 push @{ $ns->{query_queue} }, @$queue;
1940 3015
1941 if (@{ $ns->{query_queue} } == @$queue) { 3016 if (@{ $ns->{query_queue} } == @$queue) {
1942 if (@$queue) { 3017 if (@$queue) {
… …
1944 } else { 3019 } else {
1945 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 3020 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1946 } 3021 }
1947 } 3022 }
1948 }, 3023 },
3024 on_exticmd => sub {
3025 my ($ns, $buf) = @_;
3026
3027 my $msg = eval { $ns->{json_coder}->decode ($buf) };
3028
3029 if (ref $msg) {
3030 my ($type, $reply, @payload) =
3031 "ARRAY" eq ref $msg
3032 ? @$msg
3033 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
3034
3035 my @reply;
3036
3037 if (my $cb = $EXTICMD{$type}) {
3038 @reply = $cb->($ns, @payload);
3039 }
3040
3041 $ns->ext_reply ($reply, @reply)
3042 if $reply;
3043
3044 } else {
3045 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3046 }
3047
3048 cf::override;
3049 },
1949); 3050);
1950 3051
1951=item $client->async (\&cb) 3052=item $client->async (\&cb)
1952 3053
1953Create a new coroutine, running the specified callback. The coroutine will 3054Create a new coroutine, running the specified callback. The coroutine will
… …
1994our $safe = new Safe "safe"; 3095our $safe = new Safe "safe";
1995our $safe_hole = new Safe::Hole; 3096our $safe_hole = new Safe::Hole;
1996 3097
1997$SIG{FPE} = 'IGNORE'; 3098$SIG{FPE} = 'IGNORE';
1998 3099
1999$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 3100$safe->permit_only (Opcode::opset qw(
3101 :base_core :base_mem :base_orig :base_math
3102 grepstart grepwhile mapstart mapwhile
3103 sort time
3104));
2000 3105
2001# here we export the classes and methods available to script code 3106# here we export the classes and methods available to script code
2002 3107
2003=pod 3108=pod
2004 3109
2005The following fucntions and emthods are available within a safe environment: 3110The following functions and methods are available within a safe environment:
2006 3111
2007 cf::object contr pay_amount pay_player map 3112 cf::object
3113 contr pay_amount pay_player map x y force_find force_add destroy
3114 insert remove name archname title slaying race decrease split
3115
2008 cf::object::player player 3116 cf::object::player
2009 cf::player peaceful 3117 player
2010 cf::map trigger 3118
3119 cf::player
3120 peaceful
3121
3122 cf::map
3123 trigger
2011 3124
2012=cut 3125=cut
2013 3126
2014for ( 3127for (
2015 ["cf::object" => qw(contr pay_amount pay_player map)], 3128 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3129 insert remove inv nrof name archname title slaying race
3130 decrease split destroy)],
2016 ["cf::object::player" => qw(player)], 3131 ["cf::object::player" => qw(player)],
2017 ["cf::player" => qw(peaceful)], 3132 ["cf::player" => qw(peaceful)],
2018 ["cf::map" => qw(trigger)], 3133 ["cf::map" => qw(trigger)],
2019) { 3134) {
2020 no strict 'refs'; 3135 no strict 'refs';
… …
2091=back 3206=back
2092 3207
2093=cut 3208=cut
2094 3209
2095############################################################################# 3210#############################################################################
3211# the server's init and main functions
2096 3212
2097=head2 EXTENSION DATABASE SUPPORT 3213sub load_facedata($) {
3214 my ($path) = @_;
2098 3215
2099Crossfire maintains a very simple database for extension use. It can 3216 # HACK to clear player env face cache, we need some signal framework
2100currently store anything that can be serialised using Storable, which 3217 # for this (global event?)
2101excludes objects. 3218 %ext::player_env::MUSIC_FACE_CACHE = ();
2102 3219
2103The parameter C<$family> should best start with the name of the extension 3220 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2104using it, it should be unique.
2105 3221
2106=over 4 3222 warn "loading facedata from $path\n";
2107 3223
2108=item $hashref = cf::db_get $family 3224 my $facedata;
3225 0 < aio_load $path, $facedata
3226 or die "$path: $!";
2109 3227
2110Return a hashref for use by the extension C<$family>, which can be 3228 $facedata = Coro::Storable::thaw $facedata;
2111modified. After modifications, you have to call C<cf::db_dirty> or
2112C<cf::db_sync>.
2113 3229
2114=item $value = cf::db_get $family => $key 3230 $facedata->{version} == 2
3231 or cf::cleanup "$path: version mismatch, cannot proceed.";
2115 3232
2116Returns a single value from the database 3233 # patch in the exptable
2117 3234 $facedata->{resource}{"res/exp_table"} = {
2118=item cf::db_put $family => $hashref 3235 type => FT_RSRC,
2119 3236 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
2120Stores the given family hashref into the database. Updates are delayed, if
2121you want the data to be synced to disk immediately, use C<cf::db_sync>.
2122
2123=item cf::db_put $family => $key => $value
2124
2125Stores the given C<$value> in the family hash. Updates are delayed, if you
2126want the data to be synced to disk immediately, use C<cf::db_sync>.
2127
2128=item cf::db_dirty
2129
2130Marks the database as dirty, to be updated at a later time.
2131
2132=item cf::db_sync
2133
2134Immediately write the database to disk I<if it is dirty>.
2135
2136=cut
2137
2138our $DB;
2139
2140{
2141 my $path = cf::localdir . "/database.pst";
2142
2143 sub db_load() {
2144 $DB = stat $path ? Storable::retrieve $path : { };
2145 }
2146
2147 my $pid;
2148
2149 sub db_save() {
2150 waitpid $pid, 0 if $pid;
2151 if (0 == ($pid = fork)) {
2152 $DB->{_meta}{version} = 1;
2153 Storable::nstore $DB, "$path~";
2154 rename "$path~", $path;
2155 cf::_exit 0 if defined $pid;
2156 }
2157 }
2158
2159 my $dirty;
2160
2161 sub db_sync() {
2162 db_save if $dirty;
2163 undef $dirty;
2164 }
2165
2166 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2167 db_sync;
2168 }); 3237 };
3238 cf::cede_to_tick;
2169 3239
2170 sub db_dirty() {
2171 $dirty = 1;
2172 $idle->start;
2173 } 3240 {
3241 my $faces = $facedata->{faceinfo};
2174 3242
2175 sub db_get($;$) { 3243 while (my ($face, $info) = each %$faces) {
2176 @_ >= 2 3244 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2177 ? $DB->{$_[0]}{$_[1]}
2178 : ($DB->{$_[0]} ||= { })
2179 }
2180 3245
2181 sub db_put($$;$) { 3246 cf::face::set_visibility $idx, $info->{visibility};
2182 if (@_ >= 3) { 3247 cf::face::set_magicmap $idx, $info->{magicmap};
2183 $DB->{$_[0]}{$_[1]} = $_[2]; 3248 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2184 } else { 3249 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2185 $DB->{$_[0]} = $_[1];
2186 }
2187 db_dirty;
2188 }
2189 3250
2190 cf::global->attach ( 3251 cf::cede_to_tick;
2191 prio => 10000,
2192 on_cleanup => sub {
2193 db_sync;
2194 }, 3252 }
2195 );
2196}
2197 3253
2198############################################################################# 3254 while (my ($face, $info) = each %$faces) {
2199# the server's main() 3255 next unless $info->{smooth};
2200 3256
2201sub cfg_load { 3257 my $idx = cf::face::find $face
3258 or next;
3259
3260 if (my $smooth = cf::face::find $info->{smooth}) {
3261 cf::face::set_smooth $idx, $smooth;
3262 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3263 } else {
3264 warn "smooth face '$info->{smooth}' not found for face '$face'";
3265 }
3266
3267 cf::cede_to_tick;
3268 }
3269 }
3270
3271 {
3272 my $anims = $facedata->{animinfo};
3273
3274 while (my ($anim, $info) = each %$anims) {
3275 cf::anim::set $anim, $info->{frames}, $info->{facings};
3276 cf::cede_to_tick;
3277 }
3278
3279 cf::anim::invalidate_all; # d'oh
3280 }
3281
3282 {
3283 # TODO: for gcfclient pleasure, we should give resources
3284 # that gcfclient doesn't grok a >10000 face index.
3285 my $res = $facedata->{resource};
3286
3287 while (my ($name, $info) = each %$res) {
3288 if (defined $info->{type}) {
3289 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3290 my $data;
3291
3292 if ($info->{type} & 1) {
3293 # prepend meta info
3294
3295 my $meta = $enc->encode ({
3296 name => $name,
3297 %{ $info->{meta} || {} },
3298 });
3299
3300 $data = pack "(w/a*)*", $meta, $info->{data};
3301 } else {
3302 $data = $info->{data};
3303 }
3304
3305 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3306 cf::face::set_type $idx, $info->{type};
3307 } else {
3308 $RESOURCE{$name} = $info;
3309 }
3310
3311 cf::cede_to_tick;
3312 }
3313 }
3314
3315 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3316
3317 1
3318}
3319
3320cf::global->attach (on_resource_update => sub {
3321 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3322 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3323
3324 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3325 my $sound = $soundconf->{compat}[$_]
3326 or next;
3327
3328 my $face = cf::face::find "sound/$sound->[1]";
3329 cf::sound::set $sound->[0] => $face;
3330 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3331 }
3332
3333 while (my ($k, $v) = each %{$soundconf->{event}}) {
3334 my $face = cf::face::find "sound/$v";
3335 cf::sound::set $k => $face;
3336 }
3337 }
3338});
3339
3340register_exticmd fx_want => sub {
3341 my ($ns, $want) = @_;
3342
3343 while (my ($k, $v) = each %$want) {
3344 $ns->fx_want ($k, $v);
3345 }
3346};
3347
3348sub load_resource_file($) {
3349 my $guard = lock_acquire "load_resource_file";
3350
3351 my $status = load_resource_file_ $_[0];
3352 get_slot 0.1, 100;
3353 cf::arch::commit_load;
3354
3355 $status
3356}
3357
3358sub reload_regions {
3359 # HACK to clear player env face cache, we need some signal framework
3360 # for this (global event?)
3361 %ext::player_env::MUSIC_FACE_CACHE = ();
3362
3363 load_resource_file "$MAPDIR/regions"
3364 or die "unable to load regions file\n";
3365
3366 for (cf::region::list) {
3367 $_->{match} = qr/$_->{match}/
3368 if exists $_->{match};
3369 }
3370}
3371
3372sub reload_facedata {
3373 load_facedata "$DATADIR/facedata"
3374 or die "unable to load facedata\n";
3375}
3376
3377sub reload_archetypes {
3378 load_resource_file "$DATADIR/archetypes"
3379 or die "unable to load archetypes\n";
3380}
3381
3382sub reload_treasures {
3383 load_resource_file "$DATADIR/treasures"
3384 or die "unable to load treasurelists\n";
3385}
3386
3387sub reload_resources {
3388 warn "reloading resource files...\n";
3389
3390 reload_facedata;
3391 reload_archetypes;
3392 reload_regions;
3393 reload_treasures;
3394
3395 warn "finished reloading resource files\n";
3396}
3397
3398sub init {
3399 my $guard = freeze_mainloop;
3400
3401 evthread_start IO::AIO::poll_fileno;
3402
3403 reload_resources;
3404}
3405
3406sub reload_config {
2202 open my $fh, "<:utf8", cf::confdir . "/config" 3407 open my $fh, "<:utf8", "$CONFDIR/config"
2203 or return; 3408 or return;
2204 3409
2205 local $/; 3410 local $/;
2206 *CFG = YAML::Syck::Load <$fh>; 3411 *CFG = YAML::Load <$fh>;
2207 3412
2208 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3413 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2209 3414
2210 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3415 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2211 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3416 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
2221 3426
2222sub main { 3427sub main {
2223 # we must not ever block the main coroutine 3428 # we must not ever block the main coroutine
2224 local $Coro::idle = sub { 3429 local $Coro::idle = sub {
2225 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3430 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2226 async { Event::one_event }; 3431 (async {
3432 $Coro::current->{desc} = "IDLE BUG HANDLER";
3433 EV::loop EV::LOOP_ONESHOT;
3434 })->prio (Coro::PRIO_MAX);
2227 }; 3435 };
2228 3436
2229 cfg_load; 3437 {
2230 db_load; 3438 my $guard = freeze_mainloop;
3439 reload_config;
3440 db_init;
2231 load_extensions; 3441 load_extensions;
3442
3443 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3444 }
3445
2232 Event::loop; 3446 EV::loop;
2233} 3447}
2234 3448
2235############################################################################# 3449#############################################################################
2236# initialisation and cleanup 3450# initialisation and cleanup
2237 3451
2238# install some emergency cleanup handlers 3452# install some emergency cleanup handlers
2239BEGIN { 3453BEGIN {
3454 our %SIGWATCHER = ();
2240 for my $signal (qw(INT HUP TERM)) { 3455 for my $signal (qw(INT HUP TERM)) {
2241 Event->signal ( 3456 $SIGWATCHER{$signal} = EV::signal $signal, sub {
2242 data => WF_AUTOCANCEL,
2243 signal => $signal,
2244 cb => sub {
2245 cf::cleanup "SIG$signal"; 3457 cf::cleanup "SIG$signal";
2246 },
2247 ); 3458 };
3459 }
3460}
3461
3462sub write_runtime_sync {
3463 my $runtime = "$LOCALDIR/runtime";
3464
3465 # first touch the runtime file to show we are still running:
3466 # the fsync below can take a very very long time.
3467
3468 IO::AIO::aio_utime $runtime, undef, undef;
3469
3470 my $guard = cf::lock_acquire "write_runtime";
3471
3472 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3473 or return;
3474
3475 my $value = $cf::RUNTIME + 90 + 10;
3476 # 10 is the runtime save interval, for a monotonic clock
3477 # 60 allows for the watchdog to kill the server.
3478
3479 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3480 and return;
3481
3482 # always fsync - this file is important
3483 aio_fsync $fh
3484 and return;
3485
3486 # touch it again to show we are up-to-date
3487 aio_utime $fh, undef, undef;
3488
3489 close $fh
3490 or return;
3491
3492 aio_rename "$runtime~", $runtime
3493 and return;
3494
3495 warn "runtime file written.\n";
3496
2248 } 3497 1
3498}
3499
3500our $uuid_lock;
3501our $uuid_skip;
3502
3503sub write_uuid_sync($) {
3504 $uuid_skip ||= $_[0];
3505
3506 return if $uuid_lock;
3507 local $uuid_lock = 1;
3508
3509 my $uuid = "$LOCALDIR/uuid";
3510
3511 my $fh = aio_open "$uuid~", O_WRONLY | O_CREAT, 0644
3512 or return;
3513
3514 my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;
3515 $uuid_skip = 0;
3516
3517 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3518 and return;
3519
3520 # always fsync - this file is important
3521 aio_fsync $fh
3522 and return;
3523
3524 close $fh
3525 or return;
3526
3527 aio_rename "$uuid~", $uuid
3528 and return;
3529
3530 warn "uuid file written ($value).\n";
3531
3532 1
3533
3534}
3535
3536sub write_uuid($$) {
3537 my ($skip, $sync) = @_;
3538
3539 $sync ? write_uuid_sync $skip
3540 : async { write_uuid_sync $skip };
2249} 3541}
2250 3542
2251sub emergency_save() { 3543sub emergency_save() {
2252 my $freeze_guard = cf::freeze_mainloop; 3544 my $freeze_guard = cf::freeze_mainloop;
2253 3545
2254 warn "enter emergency perl save\n"; 3546 warn "enter emergency perl save\n";
2255 3547
2256 cf::sync_job { 3548 cf::sync_job {
2257 # use a peculiar iteration method to avoid tripping on perl 3549 # use a peculiar iteration method to avoid tripping on perl
2258 # refcount bugs in for. also avoids problems with players 3550 # refcount bugs in for. also avoids problems with players
2259 # and maps saved/Destroyed asynchronously. 3551 # and maps saved/destroyed asynchronously.
2260 warn "begin emergency player save\n"; 3552 warn "begin emergency player save\n";
2261 for my $login (keys %cf::PLAYER) { 3553 for my $login (keys %cf::PLAYER) {
2262 my $pl = $cf::PLAYER{$login} or next; 3554 my $pl = $cf::PLAYER{$login} or next;
2263 $pl->valid or next; 3555 $pl->valid or next;
3556 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2264 $pl->save; 3557 $pl->save;
2265 } 3558 }
2266 warn "end emergency player save\n"; 3559 warn "end emergency player save\n";
2267 3560
2268 warn "begin emergency map save\n"; 3561 warn "begin emergency map save\n";
… …
2270 my $map = $cf::MAP{$path} or next; 3563 my $map = $cf::MAP{$path} or next;
2271 $map->valid or next; 3564 $map->valid or next;
2272 $map->save; 3565 $map->save;
2273 } 3566 }
2274 warn "end emergency map save\n"; 3567 warn "end emergency map save\n";
3568
3569 warn "begin emergency database checkpoint\n";
3570 BDB::db_env_txn_checkpoint $DB_ENV;
3571 warn "end emergency database checkpoint\n";
3572
3573 warn "begin write uuid\n";
3574 write_uuid_sync 1;
3575 warn "end write uuid\n";
2275 }; 3576 };
2276 3577
2277 warn "leave emergency perl save\n"; 3578 warn "leave emergency perl save\n";
2278} 3579}
2279 3580
3581sub post_cleanup {
3582 my ($make_core) = @_;
3583
3584 warn Carp::longmess "post_cleanup backtrace"
3585 if $make_core;
3586}
3587
2280sub reload() { 3588sub do_reload_perl() {
2281 # can/must only be called in main 3589 # can/must only be called in main
2282 if ($Coro::current != $Coro::main) { 3590 if ($Coro::current != $Coro::main) {
2283 warn "can only reload from main coroutine\n"; 3591 warn "can only reload from main coroutine";
2284 return; 3592 return;
2285 } 3593 }
2286 3594
2287 warn "reloading..."; 3595 warn "reloading...";
2288 3596
2289 warn "freezing server"; 3597 warn "entering sync_job";
2290 my $guard = freeze_mainloop; 3598
3599 cf::sync_job {
3600 cf::write_runtime_sync; # external watchdog should not bark
2291 cf::emergency_save; 3601 cf::emergency_save;
3602 cf::write_runtime_sync; # external watchdog should not bark
2292 3603
2293 warn "sync database to disk"; 3604 warn "syncing database to disk";
2294 cf::db_sync; 3605 BDB::db_env_txn_checkpoint $DB_ENV;
2295 IO::AIO::flush;
2296 3606
2297 eval {
2298 # if anything goes wrong in here, we should simply crash as we already saved 3607 # if anything goes wrong in here, we should simply crash as we already saved
2299 3608
2300 warn "cancel all watchers"; 3609 warn "flushing outstanding aio requests";
2301 for (Event::all_watchers) { 3610 for (;;) {
2302 $_->cancel if $_->data & WF_AUTOCANCEL; 3611 BDB::flush;
3612 IO::AIO::flush;
3613 Coro::cede_notself;
3614 last unless IO::AIO::nreqs || BDB::nreqs;
3615 warn "iterate...";
2303 } 3616 }
2304 3617
3618 ++$RELOAD;
3619
2305 warn "cancel all extension coros"; 3620 warn "cancelling all extension coros";
2306 $_->cancel for values %EXT_CORO; 3621 $_->cancel for values %EXT_CORO;
2307 %EXT_CORO = (); 3622 %EXT_CORO = ();
2308 3623
2309 warn "remove commands"; 3624 warn "removing commands";
2310 %COMMAND = (); 3625 %COMMAND = ();
2311 3626
2312 warn "remove ext commands"; 3627 warn "removing ext/exti commands";
2313 %EXTCMD = (); 3628 %EXTCMD = ();
3629 %EXTICMD = ();
2314 3630
2315 warn "unload/nuke all extensions"; 3631 warn "unloading/nuking all extensions";
2316 for my $pkg (@EXTS) { 3632 for my $pkg (@EXTS) {
2317 warn "... unloading $pkg"; 3633 warn "... unloading $pkg";
2318 3634
2319 if (my $cb = $pkg->can ("unload")) { 3635 if (my $cb = $pkg->can ("unload")) {
2320 eval { 3636 eval {
… …
2325 3641
2326 warn "... nuking $pkg"; 3642 warn "... nuking $pkg";
2327 Symbol::delete_package $pkg; 3643 Symbol::delete_package $pkg;
2328 } 3644 }
2329 3645
2330 warn "unload all perl modules loaded from $LIBDIR"; 3646 warn "unloading all perl modules loaded from $LIBDIR";
2331 while (my ($k, $v) = each %INC) { 3647 while (my ($k, $v) = each %INC) {
2332 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3648 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2333 3649
2334 warn "removing <$k>"; 3650 warn "... unloading $k";
2335 delete $INC{$k}; 3651 delete $INC{$k};
2336 3652
2337 $k =~ s/\.pm$//; 3653 $k =~ s/\.pm$//;
2338 $k =~ s/\//::/g; 3654 $k =~ s/\//::/g;
2339 3655
… …
2342 } 3658 }
2343 3659
2344 Symbol::delete_package $k; 3660 Symbol::delete_package $k;
2345 } 3661 }
2346 3662
2347 warn "get rid of safe::, as good as possible"; 3663 warn "getting rid of safe::, as good as possible";
2348 Symbol::delete_package "safe::$_" 3664 Symbol::delete_package "safe::$_"
2349 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3665 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2350 3666
2351 warn "unload cf.pm \"a bit\""; 3667 warn "unloading cf.pm \"a bit\"";
2352 delete $INC{"cf.pm"}; 3668 delete $INC{"cf.pm"};
3669 delete $INC{"cf/pod.pm"};
2353 3670
2354 # don't, removes xs symbols, too, 3671 # don't, removes xs symbols, too,
2355 # and global variables created in xs 3672 # and global variables created in xs
2356 #Symbol::delete_package __PACKAGE__; 3673 #Symbol::delete_package __PACKAGE__;
2357 3674
3675 warn "unload completed, starting to reload now";
3676
2358 warn "reloading cf.pm"; 3677 warn "reloading cf.pm";
2359 require cf; 3678 require cf;
2360 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3679 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2361 3680
2362 warn "load config and database again"; 3681 warn "loading config and database again";
2363 cf::cfg_load; 3682 cf::reload_config;
2364 cf::db_load;
2365 3683
2366 warn "load extensions"; 3684 warn "loading extensions";
2367 cf::load_extensions; 3685 cf::load_extensions;
2368 3686
2369 warn "reattach attachments to objects/players"; 3687 warn "reattaching attachments to objects/players";
2370 _global_reattach; 3688 _global_reattach; # objects, sockets
2371 warn "reattach attachments to maps"; 3689 warn "reattaching attachments to maps";
2372 reattach $_ for values %MAP; 3690 reattach $_ for values %MAP;
3691 warn "reattaching attachments to players";
3692 reattach $_ for values %PLAYER;
3693
3694 warn "leaving sync_job";
3695
3696 1
3697 } or do {
3698 warn $@;
3699 cf::cleanup "error while reloading, exiting.";
2373 }; 3700 };
2374
2375 if ($@) {
2376 warn $@;
2377 warn "error while reloading, exiting.";
2378 exit 1;
2379 }
2380 3701
2381 warn "reloaded"; 3702 warn "reloaded";
2382}; 3703};
2383 3704
3705our $RELOAD_WATCHER; # used only during reload
3706
3707sub reload_perl() {
3708 # doing reload synchronously and two reloads happen back-to-back,
3709 # coro crashes during coro_state_free->destroy here.
3710
3711 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3712 do_reload_perl;
3713 undef $RELOAD_WATCHER;
3714 };
3715}
3716
2384register_command "reload" => sub { 3717register_command "reload" => sub {
2385 my ($who, $arg) = @_; 3718 my ($who, $arg) = @_;
2386 3719
2387 if ($who->flag (FLAG_WIZ)) { 3720 if ($who->flag (FLAG_WIZ)) {
2388 $who->message ("start of reload.");
2389 reload;
2390 $who->message ("end of reload."); 3721 $who->message ("reloading server.");
3722 async {
3723 $Coro::current->{desc} = "perl_reload";
3724 reload_perl;
3725 };
2391 } 3726 }
2392}; 3727};
2393 3728
2394unshift @INC, $LIBDIR; 3729unshift @INC, $LIBDIR;
2395 3730
2396$TICK_WATCHER = Event->timer ( 3731my $bug_warning = 0;
2397 reentrant => 0,
2398 prio => 0,
2399 at => $NEXT_TICK || $TICK,
2400 data => WF_AUTOCANCEL,
2401 cb => sub {
2402 $NOW = Event::time;
2403 3732
3733our @WAIT_FOR_TICK;
3734our @WAIT_FOR_TICK_BEGIN;
3735
3736sub wait_for_tick {
3737 return if tick_inhibit || $Coro::current == $Coro::main;
3738
3739 my $signal = new Coro::Signal;
3740 push @WAIT_FOR_TICK, $signal;
3741 $signal->wait;
3742}
3743
3744sub wait_for_tick_begin {
3745 return if tick_inhibit || $Coro::current == $Coro::main;
3746
3747 my $signal = new Coro::Signal;
3748 push @WAIT_FOR_TICK_BEGIN, $signal;
3749 $signal->wait;
3750}
3751
3752sub tick {
3753 if ($Coro::current != $Coro::main) {
3754 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3755 unless ++$bug_warning > 10;
3756 return;
3757 }
3758
2404 cf::server_tick; # one server iteration 3759 cf::server_tick; # one server iteration
2405 $RUNTIME += $TICK;
2406 $NEXT_TICK += $TICK;
2407 3760
2408 $WAIT_FOR_TICK->broadcast; 3761 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2409 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 3762 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
2410 3763 Coro::async_pool {
2411 # if we are delayed by four ticks or more, skip them all 3764 $Coro::current->{desc} = "runtime saver";
2412 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2413
2414 $TICK_WATCHER->at ($NEXT_TICK);
2415 $TICK_WATCHER->start;
2416 },
2417);
2418
2419IO::AIO::max_poll_time $TICK * 0.2;
2420
2421Event->io (
2422 fd => IO::AIO::poll_fileno,
2423 poll => 'r',
2424 prio => 5,
2425 data => WF_AUTOCANCEL,
2426 cb => \&IO::AIO::poll_cb,
2427);
2428
2429Event->timer (
2430 data => WF_AUTOCANCEL,
2431 after => 0,
2432 interval => 10,
2433 cb => sub {
2434 (Coro::unblock_sub {
2435 write_runtime 3765 write_runtime_sync
2436 or warn "ERROR: unable to write runtime file: $!"; 3766 or warn "ERROR: unable to write runtime file: $!";
2437 })->(); 3767 };
2438 }, 3768 }
2439); 3769
3770 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3771 $sig->send;
3772 }
3773 while (my $sig = shift @WAIT_FOR_TICK) {
3774 $sig->send;
3775 }
3776
3777 $LOAD = ($NOW - $TICK_START) / $TICK;
3778 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3779
3780 if (0) {
3781 if ($NEXT_TICK) {
3782 my $jitter = $TICK_START - $NEXT_TICK;
3783 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3784 warn "jitter $JITTER\n";#d#
3785 }
3786 }
3787}
3788
3789{
3790 # configure BDB
3791
3792 BDB::min_parallel 8;
3793 BDB::max_poll_reqs $TICK * 0.1;
3794 $AnyEvent::BDB::WATCHER->priority (1);
3795
3796 unless ($DB_ENV) {
3797 $DB_ENV = BDB::db_env_create;
3798 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3799 | BDB::LOG_AUTOREMOVE, 1);
3800 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3801 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3802
3803 cf::sync_job {
3804 eval {
3805 BDB::db_env_open
3806 $DB_ENV,
3807 $BDBDIR,
3808 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3809 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3810 0666;
3811
3812 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3813 };
3814
3815 cf::cleanup "db_env_open(db): $@" if $@;
3816 };
3817 }
3818
3819 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3820 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3821 };
3822 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3823 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3824 };
3825 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3826 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3827 };
3828}
3829
3830{
3831 # configure IO::AIO
3832
3833 IO::AIO::min_parallel 8;
3834 IO::AIO::max_poll_time $TICK * 0.1;
3835 undef $AnyEvent::AIO::WATCHER;
3836}
3837
3838my $_log_backtrace;
3839
3840sub _log_backtrace {
3841 my ($msg, @addr) = @_;
3842
3843 $msg =~ s/\n//;
3844
3845 # limit the # of concurrent backtraces
3846 if ($_log_backtrace < 2) {
3847 ++$_log_backtrace;
3848 async {
3849 $Coro::current->{desc} = "abt $msg";
3850
3851 my @bt = fork_call {
3852 @addr = map { sprintf "%x", $_ } @addr;
3853 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3854 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3855 or die "addr2line: $!";
3856
3857 my @funcs;
3858 my @res = <$fh>;
3859 chomp for @res;
3860 while (@res) {
3861 my ($func, $line) = splice @res, 0, 2, ();
3862 push @funcs, "[$func] $line";
3863 }
3864
3865 @funcs
3866 };
3867
3868 LOG llevInfo, "[ABT] $msg\n";
3869 LOG llevInfo, "[ABT] $_\n" for @bt;
3870 --$_log_backtrace;
3871 };
3872 } else {
3873 LOG llevInfo, "[ABT] $msg\n";
3874 LOG llevInfo, "[ABT] [suppressed]\n";
3875 }
3876}
3877
3878# load additional modules
3879use cf::pod;
2440 3880
2441END { cf::emergency_save } 3881END { cf::emergency_save }
2442 3882
24431 38831
2444 3884

Diff Legend

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