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.157 by root, Wed Jan 10 01:16:54 2007 UTC vs.
Revision 1.374 by root, Wed Sep 19 22:07:16 2007 UTC

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

Diff Legend

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