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.155 by root, Tue Jan 9 21:32:42 2007 UTC vs.
Revision 1.389 by root, Sat Oct 20 04:39:57 2007 UTC

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

Diff Legend

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