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.232 by root, Wed Apr 4 02:07:19 2007 UTC vs.
Revision 1.386 by root, Mon Oct 15 17:50:27 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 Event;
10use Opcode; 10use Opcode;
11use Safe; 11use Safe;
12use Safe::Hole; 12use Safe::Hole;
13use Storable ();
13 14
14use Coro 3.52 (); 15use Coro 4.1 ();
15use Coro::State; 16use Coro::State;
17use Coro::Handle;
16use Coro::Event; 18use Coro::Event;
17use Coro::Timer; 19use Coro::Timer;
18use Coro::Signal; 20use Coro::Signal;
19use Coro::Semaphore; 21use Coro::Semaphore;
20use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
24use Coro::Util ();
21 25
26use JSON::XS ();
22use BDB (); 27use BDB ();
23use Data::Dumper; 28use Data::Dumper;
24use Digest::MD5; 29use Digest::MD5;
25use Fcntl; 30use Fcntl;
26use YAML::Syck (); 31use YAML::Syck ();
27use IO::AIO 2.32 (); 32use IO::AIO 2.51 ();
28use Time::HiRes; 33use Time::HiRes;
29use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 ();
30 36
31# configure various modules to our taste 37# configure various modules to our taste
32# 38#
39$Storable::canonical = 1; # reduce rsync transfers
33Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
34Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
35 42
36$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
37 44
… …
45our %COMMAND = (); 52our %COMMAND = ();
46our %COMMAND_TIME = (); 53our %COMMAND_TIME = ();
47 54
48our @EXTS = (); # list of extension package names 55our @EXTS = (); # list of extension package names
49our %EXTCMD = (); 56our %EXTCMD = ();
57our %EXTICMD = ();
50our %EXT_CORO = (); # coroutines bound to extensions 58our %EXT_CORO = (); # coroutines bound to extensions
51our %EXT_MAP = (); # pluggable maps 59our %EXT_MAP = (); # pluggable maps
52 60
53our $RELOAD; # number of reloads so far 61our $RELOAD; # number of reloads so far
54our @EVENT; 62our @EVENT;
55our $LIBDIR = datadir . "/ext";
56 63
57our $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(!)
58our $TICK_WATCHER; 77our $TICK_WATCHER;
59our $AIO_POLL_WATCHER; 78our $AIO_POLL_WATCHER;
60our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
61our $NEXT_TICK; 80our $NEXT_TICK;
62our $NOW; 81our $NOW;
63our $USE_FSYNC = 1; # use fsync to write maps - default off 82our $USE_FSYNC = 1; # use fsync to write maps - default off
64 83
65our $BDB_POLL_WATCHER; 84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER;
66our $DB_ENV; 88our $DB_ENV;
67 89
68our %CFG; 90our %CFG;
69 91
70our $UPTIME; $UPTIME ||= time; 92our $UPTIME; $UPTIME ||= time;
71our $RUNTIME; 93our $RUNTIME;
72 94
73our %PLAYER; # all users 95our (%PLAYER, %PLAYER_LOADING); # all users
74our %MAP; # all maps 96our (%MAP, %MAP_LOADING ); # all maps
75our $LINK_MAP; # the special {link} map, which is always available 97our $LINK_MAP; # the special {link} map, which is always available
76our $RANDOM_MAPS = cf::localdir . "/random";
77our $BDB_ENV_DIR = cf::localdir . "/db";
78
79our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
80our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
81 98
82# used to convert map paths into valid unix filenames by replacing / by ∕ 99# used to convert map paths into valid unix filenames by replacing / by ∕
83our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
84 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
105
85binmode STDOUT; 106binmode STDOUT;
86binmode STDERR; 107binmode STDERR;
87 108
88# read virtual server time, if available 109# read virtual server time, if available
89unless ($RUNTIME || !-e cf::localdir . "/runtime") { 110unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
90 open my $fh, "<", cf::localdir . "/runtime" 111 open my $fh, "<", "$LOCALDIR/runtime"
91 or die "unable to read runtime file: $!"; 112 or die "unable to read runtime file: $!";
92 $RUNTIME = <$fh> + 0.; 113 $RUNTIME = <$fh> + 0.;
93} 114}
94 115
95mkdir cf::localdir; 116mkdir $_
96mkdir cf::localdir . "/" . cf::playerdir; 117 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
97mkdir cf::localdir . "/" . cf::tmpdir;
98mkdir cf::localdir . "/" . cf::uniquedir;
99mkdir $RANDOM_MAPS;
100mkdir $BDB_ENV_DIR;
101 118
102our $EMERGENCY_POSITION; 119our $EMERGENCY_POSITION;
103 120
104sub cf::map::normalise; 121sub cf::map::normalise;
105 122
… …
116=item $cf::RUNTIME 133=item $cf::RUNTIME
117 134
118The 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
119every server tick. 136every server tick.
120 137
121=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
122 141
123The perl library directory, where extensions and cf-specific modules can 142Various directories - "/etc", read-only install directory, perl-library
124be 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.
125 146
126=item $cf::NOW 147=item $cf::NOW
127 148
128The time of the last (current) server tick. 149The time of the last (current) server tick.
129 150
130=item $cf::TICK 151=item $cf::TICK
131 152
132The 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.
133 164
134=item %cf::CFG 165=item %cf::CFG
135 166
136Configuration for the server, loaded from C</etc/crossfire/config>, or 167Configuration for the server, loaded from C</etc/crossfire/config>, or
137from wherever your confdir points to. 168from wherever your confdir points to.
138 169
139=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 170=item cf::wait_for_tick, cf::wait_for_tick_begin
140 171
141These 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
142or 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
143processing 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.
144window 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.
145 181
146=back 182=back
147 183
148=cut 184=cut
149 185
150BEGIN { 186BEGIN {
151 *CORE::GLOBAL::warn = sub { 187 *CORE::GLOBAL::warn = sub {
152 my $msg = join "", @_; 188 my $msg = join "", @_;
153 utf8::encode $msg;
154 189
155 $msg .= "\n" 190 $msg .= "\n"
156 unless $msg =~ /\n$/; 191 unless $msg =~ /\n$/;
192
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
157 194
158 LOG llevError, $msg; 195 LOG llevError, $msg;
159 }; 196 };
160} 197}
161 198
162@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
163@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
164@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
165@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
166@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';
167@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)
168 206
169# 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
170# within the Safe compartment. 208# within the Safe compartment.
171for my $pkg (qw( 209for my $pkg (qw(
172 cf::global cf::attachable 210 cf::global cf::attachable
… …
180} 218}
181 219
182$Event::DIED = sub { 220$Event::DIED = sub {
183 warn "error in event callback: @_"; 221 warn "error in event callback: @_";
184}; 222};
223
224#############################################################################
185 225
186=head2 UTILITY FUNCTIONS 226=head2 UTILITY FUNCTIONS
187 227
188=over 4 228=over 4
189 229
… …
208 $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;
209 $d 249 $d
210 } || "[unable to dump $_[0]: '$@']"; 250 } || "[unable to dump $_[0]: '$@']";
211} 251}
212 252
213use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
214
215=item $ref = cf::from_json $json 253=item $ref = cf::from_json $json
216 254
217Converts a JSON string into the corresponding perl data structure. 255Converts a JSON string into the corresponding perl data structure.
218 256
219=item $json = cf::to_json $ref 257=item $json = cf::to_json $ref
220 258
221Converts a perl data structure into its JSON representation. 259Converts a perl data structure into its JSON representation.
260
261=cut
262
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264
265sub to_json ($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) }
222 267
223=item cf::lock_wait $string 268=item cf::lock_wait $string
224 269
225Wait until the given lock is available. See cf::lock_acquire. 270Wait until the given lock is available. See cf::lock_acquire.
226 271
… …
229Wait 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
230a 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,
231for example when the coroutine gets canceled), the lock is automatically 276for example when the coroutine gets canceled), the lock is automatically
232returned. 277returned.
233 278
279Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro.
281
234Lock 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
235uses map_find and cf::map::load uses map_load). 283uses map_find and cf::map::load uses map_load).
236 284
285=item $locked = cf::lock_active $string
286
287Return true if the lock is currently active, i.e. somebody has locked it.
288
237=cut 289=cut
238 290
239our %LOCK; 291our %LOCK;
292our %LOCKER;#d#
240 293
241sub lock_wait($) { 294sub lock_wait($) {
242 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#
243 301
244 # wait for lock, if any 302 # wait for lock, if any
245 while ($LOCK{$key}) { 303 while ($LOCK{$key}) {
246 push @{ $LOCK{$key} }, $Coro::current; 304 push @{ $LOCK{$key} }, $Coro::current;
247 Coro::schedule; 305 Coro::schedule;
… …
253 311
254 # wait, to be sure we are not locked 312 # wait, to be sure we are not locked
255 lock_wait $key; 313 lock_wait $key;
256 314
257 $LOCK{$key} = []; 315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
258 317
259 Coro::guard { 318 Coro::guard {
319 delete $LOCKER{$key};#d#
260 # wake up all waiters, to be on the safe side 320 # wake up all waiters, to be on the safe side
261 $_->ready for @{ delete $LOCK{$key} }; 321 $_->ready for @{ delete $LOCK{$key} };
262 } 322 }
323}
324
325sub lock_active($) {
326 my ($key) = @_;
327
328 ! ! $LOCK{$key}
263} 329}
264 330
265sub freeze_mainloop { 331sub freeze_mainloop {
266 return unless $TICK_WATCHER->is_active; 332 return unless $TICK_WATCHER->is_active;
267 333
… …
270 }; 336 };
271 $TICK_WATCHER->stop; 337 $TICK_WATCHER->stop;
272 $guard 338 $guard
273} 339}
274 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;
397}
398
275=item cf::async { BLOCK } 399=item cf::async { BLOCK }
276 400
277Currently the same as Coro::async_pool, meaning you cannot use 401Currently the same as Coro::async_pool, meaning you cannot use
278C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 402C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
279thing you are allowed to do is call C<prio> on it. 403thing you are allowed to do is call C<prio> on it.
… …
282 406
283BEGIN { *async = \&Coro::async_pool } 407BEGIN { *async = \&Coro::async_pool }
284 408
285=item cf::sync_job { BLOCK } 409=item cf::sync_job { BLOCK }
286 410
287The design of crossfire+ requires that the main coro ($Coro::main) is 411The design of Crossfire TRT requires that the main coroutine ($Coro::main)
288always able to handle events or runnable, as crossfire+ is only partly 412is always able to handle events or runnable, as Crossfire TRT is only
289reentrant. 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.
290 415
291If 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
292the given BLOCK in another coroutine while waiting for the result. The 417the given BLOCK in another coroutine while waiting for the result. The
293server 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
294fast or be very important. 419fast or be very important.
… …
297 422
298sub sync_job(&) { 423sub sync_job(&) {
299 my ($job) = @_; 424 my ($job) = @_;
300 425
301 if ($Coro::current == $Coro::main) { 426 if ($Coro::current == $Coro::main) {
427 my $time = Event::time;
428
302 # this is the main coro, too bad, we have to block 429 # this is the main coro, too bad, we have to block
303 # till the operation succeeds, freezing the server :/ 430 # till the operation succeeds, freezing the server :/
304 431
432 LOG llevError, Carp::longmess "sync job";#d#
433
305 # TODO: use suspend/resume instead 434 # TODO: use suspend/resume instead
306 # (but this is cancel-safe) 435 # (but this is cancel-safe)
307 my $freeze_guard = freeze_mainloop; 436 my $freeze_guard = freeze_mainloop;
308 437
309 my $busy = 1; 438 my $busy = 1;
310 my @res; 439 my @res;
311 440
312 (async { 441 (async {
442 $Coro::current->desc ("sync job coro");
313 @res = eval { $job->() }; 443 @res = eval { $job->() };
314 warn $@ if $@; 444 warn $@ if $@;
315 undef $busy; 445 undef $busy;
316 })->prio (Coro::PRIO_MAX); 446 })->prio (Coro::PRIO_MAX);
317 447
318 while ($busy) { 448 while ($busy) {
319 Coro::cede or Event::one_event; 449 Coro::cede or Event::one_event;
320 } 450 }
451
452 $time = Event::time - $time;
453
454 LOG llevError | logBacktrace, Carp::longmess "long sync job"
455 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
456
457 $tick_start += $time; # do not account sync jobs to server load
321 458
322 wantarray ? @res : $res[0] 459 wantarray ? @res : $res[0]
323 } else { 460 } else {
324 # we are in another coroutine, how wonderful, everything just works 461 # we are in another coroutine, how wonderful, everything just works
325 462
… …
345 $EXT_CORO{$coro+0} = $coro; 482 $EXT_CORO{$coro+0} = $coro;
346 483
347 $coro 484 $coro
348} 485}
349 486
350sub write_runtime { 487=item fork_call { }, $args
351 my $guard = cf::lock_acquire "write_runtime";
352 488
353 my $runtime = cf::localdir . "/runtime"; 489Executes the given code block with the given arguments in a seperate
490process, returning the results. Everything must be serialisable with
491Coro::Storable. May, of course, block. Note that the executed sub may
492never block itself or use any form of Event handling.
354 493
355 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 494=cut
356 or return;
357 495
358 my $value = $cf::RUNTIME + 90 + 10; 496sub fork_call(&@) {
359 # 10 is the runtime save interval, for a monotonic clock 497 my ($cb, @args) = @_;
360 # 60 allows for the watchdog to kill the server.
361 498
362 (aio_write $fh, 0, (length $value), $value, 0) <= 0 499 # we seemingly have to make a local copy of the whole thing,
363 and return; 500 # otherwise perl prematurely frees the stuff :/
501 # TODO: investigate and fix (likely this will be rather laborious)
364 502
365 # always fsync - this file is important 503 my @res = Coro::Util::fork_eval {
366 aio_fsync $fh 504 reset_signals;
367 and return; 505 &$cb
506 }, @args;
368 507
369 close $fh 508 wantarray ? @res : $res[-1]
370 or return; 509}
371 510
372 aio_rename "$runtime~", $runtime 511=item $value = cf::db_get $family => $key
373 and return;
374 512
513Returns a single value from the environment database.
514
515=item cf::db_put $family => $key => $value
516
517Stores the given C<$value> in the family. It can currently store binary
518data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
519
520=item $db = cf::db_table "name"
521
522Create and/or open a new database table. The string must not be "db" and must be unique
523within each server.
524
525=cut
526
527sub db_table($) {
528 my ($name) = @_;
529 my $db = BDB::db_create $DB_ENV;
530
531 eval {
532 $db->set_flags (BDB::CHKSUM);
533
534 utf8::encode $name;
535 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
536 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
537 cf::cleanup "db_open(db): $!" if $!;
538 };
539 cf::cleanup "db_open(db): $@" if $@;
540
541 $db
542}
543
544our $DB;
545
546sub db_init {
547 cf::sync_job {
548 $DB ||= db_table "db";
549 };
550}
551
552sub db_get($$) {
553 my $key = "$_[0]/$_[1]";
554
555 cf::sync_job {
556 BDB::db_get $DB, undef, $key, my $data;
557
558 $! ? ()
559 : $data
375 1 560 }
561}
562
563sub db_put($$$) {
564 BDB::dbreq_pri 4;
565 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
566}
567
568=item cf::cache $id => [$paths...], $processversion => $process
569
570Generic caching function that returns the value of the resource $id,
571caching and regenerating as required.
572
573This function can block.
574
575=cut
576
577sub cache {
578 my ($id, $src, $processversion, $process) = @_;
579
580 my $meta =
581 join "\x00",
582 $processversion,
583 map {
584 aio_stat $_
585 and Carp::croak "$_: $!";
586
587 ($_, (stat _)[7,9])
588 } @$src;
589
590 my $dbmeta = db_get cache => "$id/meta";
591 if ($dbmeta ne $meta) {
592 # changed, we may need to process
593
594 my @data;
595 my $md5;
596
597 for (0 .. $#$src) {
598 0 <= aio_load $src->[$_], $data[$_]
599 or Carp::croak "$src->[$_]: $!";
600 }
601
602 # if processing is expensive, check
603 # checksum first
604 if (1) {
605 $md5 =
606 join "\x00",
607 $processversion,
608 map {
609 cf::cede_to_tick;
610 ($src->[$_], Digest::MD5::md5_hex $data[$_])
611 } 0.. $#$src;
612
613
614 my $dbmd5 = db_get cache => "$id/md5";
615 if ($dbmd5 eq $md5) {
616 db_put cache => "$id/meta", $meta;
617
618 return db_get cache => "$id/data";
619 }
620 }
621
622 my $t1 = Time::HiRes::time;
623 my $data = $process->(\@data);
624 my $t2 = Time::HiRes::time;
625
626 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
627
628 db_put cache => "$id/data", $data;
629 db_put cache => "$id/md5" , $md5;
630 db_put cache => "$id/meta", $meta;
631
632 return $data;
633 }
634
635 db_get cache => "$id/data"
376} 636}
377 637
378=item cf::datalog type => key => value, ... 638=item cf::datalog type => key => value, ...
379 639
380Log a datalog packet of the given type with the given key-value pairs. 640Log a datalog packet of the given type with the given key-value pairs.
… …
398attach callbacks/event handlers (a collection of which is called an "attachment") 658attach callbacks/event handlers (a collection of which is called an "attachment")
399to it. All such attachable objects support the following methods. 659to it. All such attachable objects support the following methods.
400 660
401In the following description, CLASS can be any of C<global>, C<object> 661In the following description, CLASS can be any of C<global>, C<object>
402C<player>, C<client> or C<map> (i.e. the attachable objects in 662C<player>, C<client> or C<map> (i.e. the attachable objects in
403crossfire+). 663Crossfire TRT).
404 664
405=over 4 665=over 4
406 666
407=item $attachable->attach ($attachment, key => $value...) 667=item $attachable->attach ($attachment, key => $value...)
408 668
… …
571 $registry = $CB_TYPE[$object_type] ||= []; 831 $registry = $CB_TYPE[$object_type] ||= [];
572 832
573 } elsif ($type eq "subtype") { 833 } elsif ($type eq "subtype") {
574 defined $object_type or Carp::croak "subtype specified without type"; 834 defined $object_type or Carp::croak "subtype specified without type";
575 my $object_subtype = shift @arg; 835 my $object_subtype = shift @arg;
576 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 836 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
577 837
578 } elsif ($type eq "package") { 838 } elsif ($type eq "package") {
579 my $pkg = shift @arg; 839 my $pkg = shift @arg;
580 840
581 while (my ($name, $id) = each %cb_id) { 841 while (my ($name, $id) = each %cb_id) {
… …
610 _attach $registry, $klass, @attach; 870 _attach $registry, $klass, @attach;
611 } 871 }
612 872
613 $obj->{$name} = \%arg; 873 $obj->{$name} = \%arg;
614 } else { 874 } else {
615 warn "object uses attachment '$name' that is not available, postponing.\n"; 875 warn "object uses attachment '$name' which is not available, postponing.\n";
616 } 876 }
617 877
618 $obj->{_attachment}{$name} = undef; 878 $obj->{_attachment}{$name} = undef;
619} 879}
620 880
… …
622 if (ref $_[0]) { 882 if (ref $_[0]) {
623 _object_attach @_; 883 _object_attach @_;
624 } else { 884 } else {
625 _attach shift->_attach_registry, @_; 885 _attach shift->_attach_registry, @_;
626 } 886 }
887 _recalc_want;
627}; 888};
628 889
629# all those should be optimised 890# all those should be optimised
630sub cf::attachable::detach { 891sub cf::attachable::detach {
631 my ($obj, $name) = @_; 892 my ($obj, $name) = @_;
… …
634 delete $obj->{_attachment}{$name}; 895 delete $obj->{_attachment}{$name};
635 reattach ($obj); 896 reattach ($obj);
636 } else { 897 } else {
637 Carp::croak "cannot, currently, detach class attachments"; 898 Carp::croak "cannot, currently, detach class attachments";
638 } 899 }
900 _recalc_want;
639}; 901};
640 902
641sub cf::attachable::attached { 903sub cf::attachable::attached {
642 my ($obj, $name) = @_; 904 my ($obj, $name) = @_;
643 905
… …
658 "; 920 ";
659 die if $@; 921 die if $@;
660} 922}
661 923
662our $override; 924our $override;
663our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 925our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
664 926
665sub override { 927sub override {
666 $override = 1; 928 $override = 1;
667 @invoke_results = (); 929 @INVOKE_RESULTS = (@_);
668} 930}
669 931
670sub do_invoke { 932sub do_invoke {
671 my $event = shift; 933 my $event = shift;
672 my $callbacks = shift; 934 my $callbacks = shift;
673 935
674 @invoke_results = (); 936 @INVOKE_RESULTS = ();
675 937
676 local $override; 938 local $override;
677 939
678 for (@$callbacks) { 940 for (@$callbacks) {
679 eval { &{$_->[1]} }; 941 eval { &{$_->[1]} };
… …
696 958
697Generate an object-specific event with the given arguments. 959Generate an object-specific event with the given arguments.
698 960
699This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 961This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
700removed in future versions), and there is no public API to access override 962removed in future versions), and there is no public API to access override
701results (if you must, access C<@cf::invoke_results> directly). 963results (if you must, access C<@cf::INVOKE_RESULTS> directly).
702 964
703=back 965=back
704 966
705=cut 967=cut
706 968
707############################################################################# 969#############################################################################
708# object support 970# object support
971
972sub _object_equal($$);
973sub _object_equal($$) {
974 my ($a, $b) = @_;
975
976 return 0 unless (ref $a) eq (ref $b);
977
978 if ("HASH" eq ref $a) {
979 my @ka = keys %$a;
980 my @kb = keys %$b;
981
982 return 0 if @ka != @kb;
983
984 for (0 .. $#ka) {
985 return 0 unless $ka[$_] eq $kb[$_];
986 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
987 }
988
989 } elsif ("ARRAY" eq ref $a) {
990
991 return 0 if @$a != @$b;
992
993 for (0 .. $#$a) {
994 return 0 unless _object_equal $a->[$_], $b->[$_];
995 }
996
997 } elsif ($a ne $b) {
998 return 0;
999 }
1000
1001 1
1002}
1003
1004our $SLOW_MERGES;#d#
1005sub _can_merge {
1006 my ($ob1, $ob2) = @_;
1007
1008 ++$SLOW_MERGES;#d#
1009
1010 # we do the slow way here
1011 return _object_equal $ob1, $ob2
1012}
709 1013
710sub reattach { 1014sub reattach {
711 # basically do the same as instantiate, without calling instantiate 1015 # basically do the same as instantiate, without calling instantiate
712 my ($obj) = @_; 1016 my ($obj) = @_;
713 1017
… …
760sub object_freezer_save { 1064sub object_freezer_save {
761 my ($filename, $rdata, $objs) = @_; 1065 my ($filename, $rdata, $objs) = @_;
762 1066
763 sync_job { 1067 sync_job {
764 if (length $$rdata) { 1068 if (length $$rdata) {
1069 utf8::decode (my $decname = $filename);
765 warn sprintf "saving %s (%d,%d)\n", 1070 warn sprintf "saving %s (%d,%d)\n",
766 $filename, length $$rdata, scalar @$objs; 1071 $decname, length $$rdata, scalar @$objs;
767 1072
768 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1073 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
769 chmod SAVE_MODE, $fh; 1074 chmod SAVE_MODE, $fh;
770 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1075 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
771 aio_fsync $fh if $cf::USE_FSYNC; 1076 aio_fsync $fh if $cf::USE_FSYNC;
772 close $fh; 1077 close $fh;
773 1078
774 if (@$objs) { 1079 if (@$objs) {
775 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1080 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
776 chmod SAVE_MODE, $fh; 1081 chmod SAVE_MODE, $fh;
777 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1082 my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };
778 aio_write $fh, 0, (length $data), $data, 0; 1083 aio_write $fh, 0, (length $data), $data, 0;
779 aio_fsync $fh if $cf::USE_FSYNC; 1084 aio_fsync $fh if $cf::USE_FSYNC;
780 close $fh; 1085 close $fh;
781 aio_rename "$filename.pst~", "$filename.pst"; 1086 aio_rename "$filename.pst~", "$filename.pst";
782 } 1087 }
… …
790 } 1095 }
791 } else { 1096 } else {
792 aio_unlink $filename; 1097 aio_unlink $filename;
793 aio_unlink "$filename.pst"; 1098 aio_unlink "$filename.pst";
794 } 1099 }
795 } 1100 };
796} 1101}
797 1102
798sub object_freezer_as_string { 1103sub object_freezer_as_string {
799 my ($rdata, $objs) = @_; 1104 my ($rdata, $objs) = @_;
800 1105
… …
812 or return; 1117 or return;
813 1118
814 unless (aio_stat "$filename.pst") { 1119 unless (aio_stat "$filename.pst") {
815 (aio_load "$filename.pst", $av) >= 0 1120 (aio_load "$filename.pst", $av) >= 0
816 or return; 1121 or return;
817 $av = eval { (Storable::thaw $av)->{objs} };
818 }
819 1122
1123 my $st = eval { Coro::Storable::thaw $av }
1124 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1125 $av = $st->{objs};
1126 }
1127
1128 utf8::decode (my $decname = $filename);
820 warn sprintf "loading %s (%d)\n", 1129 warn sprintf "loading %s (%d,%d)\n",
821 $filename, length $data, scalar @{$av || []};#d# 1130 $decname, length $data, scalar @{$av || []};
1131
822 return ($data, $av); 1132 ($data, $av)
823} 1133}
1134
1135=head2 COMMAND CALLBACKS
1136
1137=over 4
1138
1139=cut
824 1140
825############################################################################# 1141#############################################################################
826# command handling &c 1142# command handling &c
827 1143
828=item cf::register_command $name => \&callback($ob,$args); 1144=item cf::register_command $name => \&callback($ob,$args);
… …
841 push @{ $COMMAND{$name} }, [$caller, $cb]; 1157 push @{ $COMMAND{$name} }, [$caller, $cb];
842} 1158}
843 1159
844=item cf::register_extcmd $name => \&callback($pl,$packet); 1160=item cf::register_extcmd $name => \&callback($pl,$packet);
845 1161
846Register a callbackf ro execution when the client sends an extcmd packet. 1162Register a callback for execution when the client sends an (synchronous)
1163extcmd packet. Ext commands will be processed in the order they are
1164received by the server, like other user commands. The first argument is
1165the logged-in player. Ext commands can only be processed after a player
1166has logged in successfully.
847 1167
848If the callback returns something, it is sent back as if reply was being 1168If the callback returns something, it is sent back as if reply was being
849called. 1169called.
850 1170
1171=item cf::register_exticmd $name => \&callback($ns,$packet);
1172
1173Register a callback for execution when the client sends an (asynchronous)
1174exticmd packet. Exti commands are processed by the server as soon as they
1175are received, i.e. out of order w.r.t. other commands. The first argument
1176is a client socket. Exti commands can be received anytime, even before
1177log-in.
1178
1179If the callback returns something, it is sent back as if reply was being
1180called.
1181
851=cut 1182=cut
852 1183
853sub register_extcmd { 1184sub register_extcmd {
854 my ($name, $cb) = @_; 1185 my ($name, $cb) = @_;
855 1186
856 $EXTCMD{$name} = $cb; 1187 $EXTCMD{$name} = $cb;
1188}
1189
1190sub register_exticmd {
1191 my ($name, $cb) = @_;
1192
1193 $EXTICMD{$name} = $cb;
857} 1194}
858 1195
859cf::player->attach ( 1196cf::player->attach (
860 on_command => sub { 1197 on_command => sub {
861 my ($pl, $name, $params) = @_; 1198 my ($pl, $name, $params) = @_;
… …
870 cf::override; 1207 cf::override;
871 }, 1208 },
872 on_extcmd => sub { 1209 on_extcmd => sub {
873 my ($pl, $buf) = @_; 1210 my ($pl, $buf) = @_;
874 1211
875 my $msg = eval { from_json $buf }; 1212 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
876 1213
877 if (ref $msg) { 1214 if (ref $msg) {
1215 my ($type, $reply, @payload) =
1216 "ARRAY" eq ref $msg
1217 ? @$msg
1218 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1219
1220 my @reply;
1221
878 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1222 if (my $cb = $EXTCMD{$type}) {
879 if (my %reply = $cb->($pl, $msg)) { 1223 @reply = $cb->($pl, @payload);
880 $pl->ext_reply ($msg->{msgid}, %reply);
881 }
882 } 1224 }
1225
1226 $pl->ext_reply ($reply, @reply)
1227 if $reply;
1228
883 } else { 1229 } else {
884 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1230 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
885 } 1231 }
886 1232
887 cf::override; 1233 cf::override;
888 }, 1234 },
889); 1235);
890 1236
891sub load_extension {
892 my ($path) = @_;
893
894 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
895 my $base = $1;
896 my $pkg = $1;
897 $pkg =~ s/[^[:word:]]/_/g;
898 $pkg = "ext::$pkg";
899
900 warn "... loading '$path' into '$pkg'\n";
901
902 open my $fh, "<:utf8", $path
903 or die "$path: $!";
904
905 my $source =
906 "package $pkg; use strict; use utf8;\n"
907 . "#line 1 \"$path\"\n{\n"
908 . (do { local $/; <$fh> })
909 . "\n};\n1";
910
911 unless (eval $source) {
912 my $msg = $@ ? "$path: $@\n"
913 : "extension disabled.\n";
914 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
915 warn $@;
916 warn "mandatory extension failed to load, exiting.\n";
917 exit 1;
918 }
919 die $@;
920 }
921
922 push @EXTS, $pkg;
923}
924
925sub load_extensions { 1237sub load_extensions {
1238 cf::sync_job {
1239 my %todo;
1240
926 for my $ext (<$LIBDIR/*.ext>) { 1241 for my $path (<$LIBDIR/*.ext>) {
927 next unless -r $ext; 1242 next unless -r $path;
928 eval { 1243
929 load_extension $ext; 1244 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1245 my $base = $1;
1246 my $pkg = $1;
1247 $pkg =~ s/[^[:word:]]/_/g;
1248 $pkg = "ext::$pkg";
1249
1250 open my $fh, "<:utf8", $path
1251 or die "$path: $!";
1252
1253 my $source = do { local $/; <$fh> };
1254
1255 my %ext = (
1256 path => $path,
1257 base => $base,
1258 pkg => $pkg,
1259 );
1260
1261 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1262 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1263
1264 $ext{source} =
1265 "package $pkg; use strict; use utf8;\n"
1266 . "#line 1 \"$path\"\n{\n"
1267 . $source
1268 . "\n};\n1";
1269
1270 $todo{$base} = \%ext;
1271 }
1272
1273 my %done;
1274 while (%todo) {
1275 my $progress;
1276
1277 while (my ($k, $v) = each %todo) {
1278 for (split /,\s*/, $v->{meta}{depends}) {
1279 goto skip
1280 unless exists $done{$_};
1281 }
1282
1283 warn "... loading '$k' into '$v->{pkg}'\n";
1284
1285 unless (eval $v->{source}) {
1286 my $msg = $@ ? "$v->{path}: $@\n"
1287 : "$v->{base}: extension inactive.\n";
1288
1289 if (exists $v->{meta}{mandatory}) {
1290 warn $msg;
1291 warn "mandatory extension failed to load, exiting.\n";
1292 exit 1;
1293 }
1294
1295 warn $msg;
1296 }
1297
1298 $done{$k} = delete $todo{$k};
1299 push @EXTS, $v->{pkg};
1300 $progress = 1;
930 1 1301 }
931 } or warn "$ext not loaded: $@"; 1302
1303 skip:
1304 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1305 unless $progress;
1306 }
932 } 1307 };
933} 1308}
934 1309
935############################################################################# 1310#############################################################################
936 1311
1312=back
1313
937=head2 CORE EXTENSIONS 1314=head2 CORE EXTENSIONS
938 1315
939Functions and methods that extend core crossfire objects. 1316Functions and methods that extend core crossfire objects.
940 1317
941=cut 1318=cut
… …
946 1323
947=head3 cf::player 1324=head3 cf::player
948 1325
949=over 4 1326=over 4
950 1327
1328=item cf::player::num_playing
1329
1330Returns the official number of playing players, as per the Crossfire metaserver rules.
1331
1332=cut
1333
1334sub num_playing {
1335 scalar grep
1336 $_->ob->map
1337 && !$_->hidden
1338 && !$_->ob->flag (cf::FLAG_WIZ),
1339 cf::player::list
1340}
1341
951=item cf::player::find $login 1342=item cf::player::find $login
952 1343
953Returns the given player object, loading it if necessary (might block). 1344Returns the given player object, loading it if necessary (might block).
954 1345
955=cut 1346=cut
956 1347
957sub playerdir($) { 1348sub playerdir($) {
958 cf::localdir 1349 "$PLAYERDIR/"
959 . "/"
960 . cf::playerdir
961 . "/"
962 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1350 . (ref $_[0] ? $_[0]->ob->name : $_[0])
963} 1351}
964 1352
965sub path($) { 1353sub path($) {
966 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1354 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
967 1355
968 (playerdir $login) . "/$login.pl" 1356 (playerdir $login) . "/playerdata"
969} 1357}
970 1358
971sub find_active($) { 1359sub find_active($) {
972 $cf::PLAYER{$_[0]} 1360 $cf::PLAYER{$_[0]}
973 and $cf::PLAYER{$_[0]}->active 1361 and $cf::PLAYER{$_[0]}->active
… …
986 my $login = $_[0]; 1374 my $login = $_[0];
987 1375
988 my $guard = cf::lock_acquire "user_find:$login"; 1376 my $guard = cf::lock_acquire "user_find:$login";
989 1377
990 $cf::PLAYER{$_[0]} || do { 1378 $cf::PLAYER{$_[0]} || do {
991 my $pl = load_pl path $login 1379 # rename old playerfiles to new ones
1380 #TODO: remove when no longer required
1381 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1382 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1383 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1384 aio_unlink +(playerdir $login) . "/$login.pl";
1385
1386 my $f = new_from_file cf::object::thawer path $login
992 or return; 1387 or return;
1388
1389 my $pl = cf::player::load_pl $f
1390 or return;
1391 local $cf::PLAYER_LOADING{$login} = $pl;
1392 $f->resolve_delayed_derefs;
993 $cf::PLAYER{$login} = $pl 1393 $cf::PLAYER{$login} = $pl
994 } 1394 }
995 } 1395 }
996} 1396}
997 1397
… …
1007 1407
1008 aio_mkdir playerdir $pl, 0770; 1408 aio_mkdir playerdir $pl, 0770;
1009 $pl->{last_save} = $cf::RUNTIME; 1409 $pl->{last_save} = $cf::RUNTIME;
1010 1410
1011 $pl->save_pl ($path); 1411 $pl->save_pl ($path);
1012 Coro::cede; 1412 cf::cede_to_tick;
1013} 1413}
1014 1414
1015sub new($) { 1415sub new($) {
1016 my ($login) = @_; 1416 my ($login) = @_;
1017 1417
… …
1021 $self->{deny_save} = 1; 1421 $self->{deny_save} = 1;
1022 1422
1023 $cf::PLAYER{$login} = $self; 1423 $cf::PLAYER{$login} = $self;
1024 1424
1025 $self 1425 $self
1426}
1427
1428=item $player->send_msg ($channel, $msg, $color, [extra...])
1429
1430=cut
1431
1432sub send_msg {
1433 my $ns = shift->ns
1434 or return;
1435 $ns->send_msg (@_);
1026} 1436}
1027 1437
1028=item $pl->quit_character 1438=item $pl->quit_character
1029 1439
1030Nukes the player without looking back. If logged in, the connection will 1440Nukes the player without looking back. If logged in, the connection will
… …
1079while and may block, so not sync_job-capable, ever. 1489while and may block, so not sync_job-capable, ever.
1080 1490
1081=cut 1491=cut
1082 1492
1083sub list_logins { 1493sub list_logins {
1084 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1494 my $dirs = aio_readdir $PLAYERDIR
1085 or return []; 1495 or return [];
1086 1496
1087 my @logins; 1497 my @logins;
1088 1498
1089 for my $login (@$dirs) { 1499 for my $login (@$dirs) {
1500 my $path = path $login;
1501
1502 # a .pst is a dead give-away for a valid player
1503 unless (-e "$path.pst") {
1090 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1504 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1091 aio_read $fh, 0, 512, my $buf, 0 or next; 1505 aio_read $fh, 0, 512, my $buf, 0 or next;
1092 $buf !~ /^password -------------$/m or next; # official not-valid tag 1506 $buf !~ /^password -------------$/m or next; # official not-valid tag
1507 }
1093 1508
1094 utf8::decode $login; 1509 utf8::decode $login;
1095 push @logins, $login; 1510 push @logins, $login;
1096 } 1511 }
1097 1512
… …
1124 } 1539 }
1125 1540
1126 \@paths 1541 \@paths
1127} 1542}
1128 1543
1544=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1545
1546Expand crossfire pod fragments into protocol xml.
1547
1548=cut
1549
1550sub expand_cfpod {
1551 ((my $self), (local $_)) = @_;
1552
1553 # escape & and <
1554 s/&/&amp;/g;
1555 s/(?<![BIUGHT])</&lt;/g;
1556
1557 # this is buggy, it needs to properly take care of nested <'s
1558
1559 1 while
1560 # replace B<>, I<>, U<> etc.
1561 s/B<([^\>]*)>/<b>$1<\/b>/
1562 || s/I<([^\>]*)>/<i>$1<\/i>/
1563 || s/U<([^\>]*)>/<u>$1<\/u>/
1564 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1565 # replace G<male|female> tags
1566 || s{G<([^>|]*)\|([^>]*)>}{
1567 $self->gender ? $2 : $1
1568 }ge
1569 # replace H<hint text>
1570 || s{H<([^\>]*)>}
1571 {
1572 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1573 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1574 "")
1575 [$self->{hintmode}]
1576 }ge;
1577
1578 # create single paragraphs (very hackish)
1579 s/(?<=\S)\n(?=\w)/ /g;
1580
1581 # compress some whitespace
1582 s/\s+\n/\n/g; # ws line-ends
1583 s/\n\n+/\n/g; # double lines
1584 s/^\n+//; # beginning lines
1585 s/\n+$//; # ending lines
1586
1587 $_
1588}
1589
1590sub hintmode {
1591 $_[0]{hintmode} = $_[1] if @_ > 1;
1592 $_[0]{hintmode}
1593}
1594
1129=item $player->ext_reply ($msgid, %msg) 1595=item $player->ext_reply ($msgid, @msg)
1130 1596
1131Sends an ext reply to the player. 1597Sends an ext reply to the player.
1132 1598
1133=cut 1599=cut
1134 1600
1135sub ext_reply($$%) { 1601sub ext_reply($$@) {
1136 my ($self, $id, %msg) = @_; 1602 my ($self, $id, @msg) = @_;
1137 1603
1138 $msg{msgid} = $id; 1604 $self->ns->ext_reply ($id, @msg)
1139
1140 $self->send ("ext " . cf::to_json \%msg);
1141} 1605}
1142 1606
1143=item $player->ext_event ($type, %msg) 1607=item $player->ext_msg ($type, @msg)
1144 1608
1145Sends an ext event to the client. 1609Sends an ext event to the client.
1146 1610
1147=cut 1611=cut
1148 1612
1149sub ext_event($$%) { 1613sub ext_msg($$@) {
1150 my ($self, $type, %msg) = @_; 1614 my ($self, $type, @msg) = @_;
1151 1615
1152 $self->ns->ext_event ($type, %msg); 1616 $self->ns->ext_msg ($type, @msg);
1153} 1617}
1154 1618
1155package cf; 1619=head3 cf::region
1620
1621=over 4
1622
1623=cut
1624
1625package cf::region;
1626
1627=item cf::region::find_by_path $path
1628
1629Tries to decuce the likely region for a map knowing only its path.
1630
1631=cut
1632
1633sub find_by_path($) {
1634 my ($path) = @_;
1635
1636 my ($match, $specificity);
1637
1638 for my $region (list) {
1639 if ($region->{match} && $path =~ $region->{match}) {
1640 ($match, $specificity) = ($region, $region->specificity)
1641 if $region->specificity > $specificity;
1642 }
1643 }
1644
1645 $match
1646}
1156 1647
1157=back 1648=back
1158
1159 1649
1160=head3 cf::map 1650=head3 cf::map
1161 1651
1162=over 4 1652=over 4
1163 1653
… …
1218 my ($self, $merge) = @_; 1708 my ($self, $merge) = @_;
1219 1709
1220 # we have to keep some variables in memory intact 1710 # we have to keep some variables in memory intact
1221 local $self->{path}; 1711 local $self->{path};
1222 local $self->{load_path}; 1712 local $self->{load_path};
1223 local $self->{deny_save};
1224 local $self->{deny_reset};
1225 1713
1226 $self->SUPER::thawer_merge ($merge); 1714 $self->SUPER::thawer_merge ($merge);
1227} 1715}
1228 1716
1229sub normalise { 1717sub normalise {
… …
1276 $self->init; # pass $1 etc. 1764 $self->init; # pass $1 etc.
1277 return $self; 1765 return $self;
1278 } 1766 }
1279 } 1767 }
1280 1768
1281 Carp::carp "unable to resolve path '$path' (base '$base')."; 1769 Carp::cluck "unable to resolve path '$path' (base '$base').";
1282 () 1770 ()
1283} 1771}
1284 1772
1285sub init { 1773sub init {
1286 my ($self) = @_; 1774 my ($self) = @_;
… …
1301 1789
1302# the original (read-only) location 1790# the original (read-only) location
1303sub load_path { 1791sub load_path {
1304 my ($self) = @_; 1792 my ($self) = @_;
1305 1793
1306 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1794 "$MAPDIR/$self->{path}.map"
1307} 1795}
1308 1796
1309# the temporary/swap location 1797# the temporary/swap location
1310sub save_path { 1798sub save_path {
1311 my ($self) = @_; 1799 my ($self) = @_;
1312 1800
1313 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1801 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1314 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1802 "$TMPDIR/$path.map"
1315} 1803}
1316 1804
1317# the unique path, undef == no special unique path 1805# the unique path, undef == no special unique path
1318sub uniq_path { 1806sub uniq_path {
1319 my ($self) = @_; 1807 my ($self) = @_;
1320 1808
1321 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1809 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1322 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1810 "$UNIQUEDIR/$path"
1323} 1811}
1324 1812
1325# and all this just because we cannot iterate over 1813# and all this just because we cannot iterate over
1326# all maps in C++... 1814# all maps in C++...
1327sub change_all_map_light { 1815sub change_all_map_light {
… …
1329 1817
1330 $_->change_map_light ($change) 1818 $_->change_map_light ($change)
1331 for grep $_->outdoor, values %cf::MAP; 1819 for grep $_->outdoor, values %cf::MAP;
1332} 1820}
1333 1821
1822sub decay_objects {
1823 my ($self) = @_;
1824
1825 return if $self->{deny_reset};
1826
1827 $self->do_decay_objects;
1828}
1829
1334sub unlink_save { 1830sub unlink_save {
1335 my ($self) = @_; 1831 my ($self) = @_;
1336 1832
1337 utf8::encode (my $save = $self->save_path); 1833 utf8::encode (my $save = $self->save_path);
1338 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1834 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1341 1837
1342sub load_header_from($) { 1838sub load_header_from($) {
1343 my ($self, $path) = @_; 1839 my ($self, $path) = @_;
1344 1840
1345 utf8::encode $path; 1841 utf8::encode $path;
1346 #aio_open $path, O_RDONLY, 0 1842 my $f = new_from_file cf::object::thawer $path
1347 # or return;
1348
1349 $self->_load_header ($path)
1350 or return; 1843 or return;
1844
1845 $self->_load_header ($f)
1846 or return;
1847
1848 local $MAP_LOADING{$self->{path}} = $self;
1849 $f->resolve_delayed_derefs;
1351 1850
1352 $self->{load_path} = $path; 1851 $self->{load_path} = $path;
1353 1852
1354 1 1853 1
1355} 1854}
… …
1394 $self->load_header_orig 1893 $self->load_header_orig
1395 or return; 1894 or return;
1396 $self->prepare_orig; 1895 $self->prepare_orig;
1397 } 1896 }
1398 1897
1898 $self->{deny_reset} = 1
1899 if $self->no_reset;
1900
1901 $self->default_region (cf::region::find_by_path $self->{path})
1902 unless $self->default_region;
1903
1399 1 1904 1
1400} 1905}
1401 1906
1402sub find; 1907sub find;
1403sub find { 1908sub find {
1404 my ($path, $origin) = @_; 1909 my ($path, $origin) = @_;
1405 1910
1406 $path = normalise $path, $origin && $origin->path; 1911 $path = normalise $path, $origin && $origin->path;
1407 1912
1913 cf::lock_wait "map_data:$path";#d#remove
1408 cf::lock_wait "map_find:$path"; 1914 cf::lock_wait "map_find:$path";
1409 1915
1410 $cf::MAP{$path} || do { 1916 $cf::MAP{$path} || do {
1411 my $guard = cf::lock_acquire "map_find:$path"; 1917 my $guard1 = cf::lock_acquire "map_find:$path";
1918 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1919
1412 my $map = new_from_path cf::map $path 1920 my $map = new_from_path cf::map $path
1413 or return; 1921 or return;
1414 1922
1415 $map->{last_save} = $cf::RUNTIME; 1923 $map->{last_save} = $cf::RUNTIME;
1416 1924
1417 $map->load_header 1925 $map->load_header
1418 or return; 1926 or return;
1419 1927
1420 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1928 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1421 # doing this can freeze the server in a sync job, obviously 1929 # doing this can freeze the server in a sync job, obviously
1422 #$cf::WAIT_FOR_TICK->wait; 1930 #$cf::WAIT_FOR_TICK->wait;
1931 undef $guard1;
1932 undef $guard2;
1423 $map->reset; 1933 $map->reset;
1424 undef $guard;
1425 return find $path; 1934 return find $path;
1426 } 1935 }
1427 1936
1428 $cf::MAP{$path} = $map 1937 $cf::MAP{$path} = $map
1429 } 1938 }
… …
1436 my ($self) = @_; 1945 my ($self) = @_;
1437 1946
1438 local $self->{deny_reset} = 1; # loading can take a long time 1947 local $self->{deny_reset} = 1; # loading can take a long time
1439 1948
1440 my $path = $self->{path}; 1949 my $path = $self->{path};
1950
1951 {
1441 my $guard = cf::lock_acquire "map_load:$path"; 1952 my $guard = cf::lock_acquire "map_data:$path";
1442 1953
1954 return unless $self->valid;
1443 return if $self->in_memory != cf::MAP_SWAPPED; 1955 return unless $self->in_memory == cf::MAP_SWAPPED;
1444 1956
1445 $self->in_memory (cf::MAP_LOADING); 1957 $self->in_memory (cf::MAP_LOADING);
1446 1958
1447 $self->alloc; 1959 $self->alloc;
1448 1960
1449 $self->pre_load; 1961 $self->pre_load;
1962 cf::cede_to_tick;
1450 1963
1451 $self->_load_objects ($self->{load_path}, 1) 1964 my $f = new_from_file cf::object::thawer $self->{load_path};
1965 $f->skip_block;
1966 $self->_load_objects ($f)
1452 or return; 1967 or return;
1453 1968
1454 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1969 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1455 if delete $self->{load_original}; 1970 if delete $self->{load_original};
1456 1971
1457 if (my $uniq = $self->uniq_path) { 1972 if (my $uniq = $self->uniq_path) {
1458 utf8::encode $uniq; 1973 utf8::encode $uniq;
1459 if (aio_open $uniq, O_RDONLY, 0) { 1974 unless (aio_stat $uniq) {
1975 if (my $f = new_from_file cf::object::thawer $uniq) {
1460 $self->clear_unique_items; 1976 $self->clear_unique_items;
1461 $self->_load_objects ($uniq, 0); 1977 $self->_load_objects ($f);
1978 $f->resolve_delayed_derefs;
1979 }
1462 } 1980 }
1463 } 1981 }
1464 1982
1465 Coro::cede; 1983 $f->resolve_delayed_derefs;
1466 1984
1985 cf::cede_to_tick;
1467 # now do the right thing for maps 1986 # now do the right thing for maps
1468 $self->link_multipart_objects; 1987 $self->link_multipart_objects;
1469
1470 unless ($self->{deny_activate}) {
1471 $self->decay_objects;
1472 $self->fix_auto_apply;
1473 $self->update_buttons;
1474 Coro::cede;
1475 $self->set_darkness_map;
1476 $self->difficulty ($self->estimate_difficulty) 1988 $self->difficulty ($self->estimate_difficulty)
1477 unless $self->difficulty; 1989 unless $self->difficulty;
1478 Coro::cede; 1990 cf::cede_to_tick;
1991
1992 unless ($self->{deny_activate}) {
1993 $self->decay_objects;
1994 $self->fix_auto_apply;
1995 $self->update_buttons;
1996 cf::cede_to_tick;
1997 $self->set_darkness_map;
1998 cf::cede_to_tick;
1479 $self->activate; 1999 $self->activate;
2000 }
2001
2002 $self->{last_save} = $cf::RUNTIME;
2003 $self->last_access ($cf::RUNTIME);
2004
2005 $self->in_memory (cf::MAP_IN_MEMORY);
1480 } 2006 }
1481 2007
1482 $self->post_load; 2008 $self->post_load;
1483
1484 $self->in_memory (cf::MAP_IN_MEMORY);
1485} 2009}
1486 2010
1487sub customise_for { 2011sub customise_for {
1488 my ($self, $ob) = @_; 2012 my ($self, $ob) = @_;
1489 2013
1490 return find "~" . $ob->name . "/" . $self->{path} 2014 return find "~" . $ob->name . "/" . $self->{path}
1491 if $self->per_player; 2015 if $self->per_player;
1492 2016
2017# return find "?party/" . $ob->name . "/" . $self->{path}
2018# if $self->per_party;
2019
1493 $self 2020 $self
1494} 2021}
1495 2022
1496# find and load all maps in the 3x3 area around a map 2023# find and load all maps in the 3x3 area around a map
1497sub load_diag { 2024sub load_neighbours {
1498 my ($map) = @_; 2025 my ($map) = @_;
1499 2026
1500 my @diag; # diagonal neighbours 2027 my @neigh; # diagonal neighbours
1501 2028
1502 for (0 .. 3) { 2029 for (0 .. 3) {
1503 my $neigh = $map->tile_path ($_) 2030 my $neigh = $map->tile_path ($_)
1504 or next; 2031 or next;
1505 $neigh = find $neigh, $map 2032 $neigh = find $neigh, $map
1506 or next; 2033 or next;
1507 $neigh->load; 2034 $neigh->load;
1508 2035
2036 push @neigh,
1509 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2037 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1510 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2038 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1511 } 2039 }
1512 2040
1513 for (@diag) { 2041 for (grep defined $_->[0], @neigh) {
2042 my ($path, $origin) = @$_;
1514 my $neigh = find @$_ 2043 my $neigh = find $path, $origin
1515 or next; 2044 or next;
1516 $neigh->load; 2045 $neigh->load;
1517 } 2046 }
1518} 2047}
1519 2048
… …
1524} 2053}
1525 2054
1526sub do_load_sync { 2055sub do_load_sync {
1527 my ($map) = @_; 2056 my ($map) = @_;
1528 2057
2058 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2059 if $Coro::current == $Coro::main;
2060
1529 cf::sync_job { $map->load }; 2061 cf::sync_job { $map->load };
1530} 2062}
1531 2063
1532our %MAP_PREFETCH; 2064our %MAP_PREFETCH;
1533our $MAP_PREFETCHER = undef; 2065our $MAP_PREFETCHER = undef;
1534 2066
1535sub find_async { 2067sub find_async {
1536 my ($path, $origin) = @_; 2068 my ($path, $origin, $load) = @_;
1537 2069
1538 $path = normalise $path, $origin && $origin->{path}; 2070 $path = normalise $path, $origin && $origin->{path};
1539 2071
1540 if (my $map = $cf::MAP{$path}) { 2072 if (my $map = $cf::MAP{$path}) {
1541 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2073 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1542 } 2074 }
1543 2075
1544 undef $MAP_PREFETCH{$path}; 2076 $MAP_PREFETCH{$path} |= $load;
2077
1545 $MAP_PREFETCHER ||= cf::async { 2078 $MAP_PREFETCHER ||= cf::async {
2079 $Coro::current->{desc} = "map prefetcher";
2080
1546 while (%MAP_PREFETCH) { 2081 while (%MAP_PREFETCH) {
1547 for my $path (keys %MAP_PREFETCH) { 2082 while (my ($k, $v) = each %MAP_PREFETCH) {
1548 my $map = find $path 2083 if (my $map = find $k) {
1549 or next;
1550 $map->load; 2084 $map->load if $v;
2085 }
1551 2086
1552 delete $MAP_PREFETCH{$path}; 2087 delete $MAP_PREFETCH{$k};
1553 } 2088 }
1554 } 2089 }
1555 undef $MAP_PREFETCHER; 2090 undef $MAP_PREFETCHER;
1556 }; 2091 };
1557 $MAP_PREFETCHER->prio (6); 2092 $MAP_PREFETCHER->prio (6);
… …
1560} 2095}
1561 2096
1562sub save { 2097sub save {
1563 my ($self) = @_; 2098 my ($self) = @_;
1564 2099
1565 my $lock = cf::lock_acquire "map_data:" . $self->path; 2100 my $lock = cf::lock_acquire "map_data:$self->{path}";
1566 2101
1567 $self->{last_save} = $cf::RUNTIME; 2102 $self->{last_save} = $cf::RUNTIME;
1568 2103
1569 return unless $self->dirty; 2104 return unless $self->dirty;
1570 2105
… …
1576 return if $self->{deny_save}; 2111 return if $self->{deny_save};
1577 2112
1578 local $self->{last_access} = $self->last_access;#d# 2113 local $self->{last_access} = $self->last_access;#d#
1579 2114
1580 cf::async { 2115 cf::async {
2116 $Coro::current->{desc} = "map player save";
1581 $_->contr->save for $self->players; 2117 $_->contr->save for $self->players;
1582 }; 2118 };
1583 2119
1584 if ($uniq) { 2120 if ($uniq) {
1585 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2121 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1593 my ($self) = @_; 2129 my ($self) = @_;
1594 2130
1595 # save first because save cedes 2131 # save first because save cedes
1596 $self->save; 2132 $self->save;
1597 2133
1598 my $lock = cf::lock_acquire "map_data:" . $self->path; 2134 my $lock = cf::lock_acquire "map_data:$self->{path}";
1599 2135
1600 return if $self->players; 2136 return if $self->players;
1601 return if $self->in_memory != cf::MAP_IN_MEMORY; 2137 return if $self->in_memory != cf::MAP_IN_MEMORY;
1602 return if $self->{deny_save}; 2138 return if $self->{deny_save};
1603 2139
2140 $self->in_memory (cf::MAP_SWAPPED);
2141
2142 $self->deactivate;
2143 $_->clear_links_to ($self) for values %cf::MAP;
1604 $self->clear; 2144 $self->clear;
1605 $self->in_memory (cf::MAP_SWAPPED);
1606} 2145}
1607 2146
1608sub reset_at { 2147sub reset_at {
1609 my ($self) = @_; 2148 my ($self) = @_;
1610 2149
1611 # TODO: safety, remove and allow resettable per-player maps 2150 # TODO: safety, remove and allow resettable per-player maps
1612 return 1e99 if $self->isa ("ext::map_per_player");#d#
1613 return 1e99 if $self->{deny_reset}; 2151 return 1e99 if $self->{deny_reset};
1614 2152
1615 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2153 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1616 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2154 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1617 2155
… …
1628 my ($self) = @_; 2166 my ($self) = @_;
1629 2167
1630 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2168 my $lock = cf::lock_acquire "map_data:$self->{path}";
1631 2169
1632 return if $self->players; 2170 return if $self->players;
1633 return if $self->isa ("ext::map_per_player");#d#
1634 2171
1635 warn "resetting map ", $self->path;#d# 2172 warn "resetting map ", $self->path;
1636 2173
1637 $self->in_memory (cf::MAP_SWAPPED); 2174 $self->in_memory (cf::MAP_SWAPPED);
1638 2175
1639 # need to save uniques path 2176 # need to save uniques path
1640 unless ($self->{deny_save}) { 2177 unless ($self->{deny_save}) {
… …
1644 if $uniq; 2181 if $uniq;
1645 } 2182 }
1646 2183
1647 delete $cf::MAP{$self->path}; 2184 delete $cf::MAP{$self->path};
1648 2185
2186 $self->deactivate;
2187 $_->clear_links_to ($self) for values %cf::MAP;
1649 $self->clear; 2188 $self->clear;
1650
1651 $_->clear_links_to ($self) for values %cf::MAP;
1652 2189
1653 $self->unlink_save; 2190 $self->unlink_save;
1654 $self->destroy; 2191 $self->destroy;
1655} 2192}
1656 2193
1657my $nuke_counter = "aaaa"; 2194my $nuke_counter = "aaaa";
1658 2195
1659sub nuke { 2196sub nuke {
1660 my ($self) = @_; 2197 my ($self) = @_;
1661 2198
2199 {
2200 my $lock = cf::lock_acquire "map_data:$self->{path}";
2201
1662 delete $cf::MAP{$self->path}; 2202 delete $cf::MAP{$self->path};
1663 2203
1664 $self->unlink_save; 2204 $self->unlink_save;
1665 2205
1666 bless $self, "cf::map"; 2206 bless $self, "cf::map";
1667 delete $self->{deny_reset}; 2207 delete $self->{deny_reset};
1668 $self->{deny_save} = 1; 2208 $self->{deny_save} = 1;
1669 $self->reset_timeout (1); 2209 $self->reset_timeout (1);
1670 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2210 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1671 2211
1672 $cf::MAP{$self->path} = $self; 2212 $cf::MAP{$self->path} = $self;
2213 }
1673 2214
1674 $self->reset; # polite request, might not happen 2215 $self->reset; # polite request, might not happen
2216}
2217
2218=item $maps = cf::map::tmp_maps
2219
2220Returns an arrayref with all map paths of currently instantiated and saved
2221maps. May block.
2222
2223=cut
2224
2225sub tmp_maps() {
2226 [
2227 map {
2228 utf8::decode $_;
2229 /\.map$/
2230 ? normalise $_
2231 : ()
2232 } @{ aio_readdir $TMPDIR or [] }
2233 ]
2234}
2235
2236=item $maps = cf::map::random_maps
2237
2238Returns an arrayref with all map paths of currently instantiated and saved
2239random maps. May block.
2240
2241=cut
2242
2243sub random_maps() {
2244 [
2245 map {
2246 utf8::decode $_;
2247 /\.map$/
2248 ? normalise "?random/$_"
2249 : ()
2250 } @{ aio_readdir $RANDOMDIR or [] }
2251 ]
1675} 2252}
1676 2253
1677=item cf::map::unique_maps 2254=item cf::map::unique_maps
1678 2255
1679Returns an arrayref of paths of all shared maps that have 2256Returns an arrayref of paths of all shared maps that have
1680instantiated unique items. May block. 2257instantiated unique items. May block.
1681 2258
1682=cut 2259=cut
1683 2260
1684sub unique_maps() { 2261sub unique_maps() {
1685 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2262 [
1686 or return; 2263 map {
1687
1688 my @paths;
1689
1690 for (@$files) {
1691 utf8::decode $_; 2264 utf8::decode $_;
1692 next if /\.pst$/; 2265 /\.map$/
1693 next unless /^$PATH_SEP/o; 2266 ? normalise $_
1694 2267 : ()
1695 push @paths, cf::map::normalise $_; 2268 } @{ aio_readdir $UNIQUEDIR or [] }
1696 } 2269 ]
1697
1698 \@paths
1699} 2270}
1700 2271
1701package cf; 2272package cf;
1702 2273
1703=back 2274=back
… …
1721 map { $_, inv_recursive_ $_->inv } @_ 2292 map { $_, inv_recursive_ $_->inv } @_
1722} 2293}
1723 2294
1724sub inv_recursive { 2295sub inv_recursive {
1725 inv_recursive_ inv $_[0] 2296 inv_recursive_ inv $_[0]
2297}
2298
2299=item $ref = $ob->ref
2300
2301creates and returns a persistent reference to an objetc that can be stored as a string.
2302
2303=item $ob = cf::object::deref ($refstring)
2304
2305returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2306even if the object actually exists. May block.
2307
2308=cut
2309
2310sub deref {
2311 my ($ref) = @_;
2312
2313 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2314 my ($uuid, $name) = ($1, $2);
2315 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2316 or return;
2317 $pl->ob->uuid eq $uuid
2318 or return;
2319
2320 $pl->ob
2321 } else {
2322 warn "$ref: cannot resolve object reference\n";
2323 undef
2324 }
1726} 2325}
1727 2326
1728package cf; 2327package cf;
1729 2328
1730=back 2329=back
… …
1749 2348
1750 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2349 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1751 2350
1752 if ($self->{record_replies}) { 2351 if ($self->{record_replies}) {
1753 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2352 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2353
1754 } else { 2354 } else {
2355 my $pl = $self->contr;
2356
2357 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2358 my $dialog = $pl->{npc_dialog};
2359 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2360
2361 } else {
1755 $msg = $npc->name . " says: $msg" if $npc; 2362 $msg = $npc->name . " says: $msg" if $npc;
1756 $self->message ($msg, $flags); 2363 $self->message ($msg, $flags);
2364 }
1757 } 2365 }
2366}
2367
2368=item $object->send_msg ($channel, $msg, $color, [extra...])
2369
2370=cut
2371
2372sub cf::object::send_msg {
2373 my $pl = shift->contr
2374 or return;
2375 $pl->send_msg (@_);
1758} 2376}
1759 2377
1760=item $player_object->may ("access") 2378=item $player_object->may ("access")
1761 2379
1762Returns wether the given player is authorized to access resource "access" 2380Returns wether the given player is authorized to access resource "access"
… …
1809 $self->deactivate_recursive; 2427 $self->deactivate_recursive;
1810 2428
1811 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2429 return if UNIVERSAL::isa $self->map, "ext::map_link";
1812 2430
1813 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2431 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1814 if $self->map; 2432 if $self->map && $self->map->{path} ne "{link}";
1815 2433
1816 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2434 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1817} 2435}
1818 2436
1819sub cf::object::player::leave_link { 2437sub cf::object::player::leave_link {
1820 my ($self, $map, $x, $y) = @_; 2438 my ($self, $map, $x, $y) = @_;
2439
2440 return unless $self->contr->active;
1821 2441
1822 my $link_pos = delete $self->{_link_pos}; 2442 my $link_pos = delete $self->{_link_pos};
1823 2443
1824 unless ($map) { 2444 unless ($map) {
1825 # restore original map position 2445 # restore original map position
… …
1839 # use -1 or undef as default coordinates, not 0, 0 2459 # use -1 or undef as default coordinates, not 0, 0
1840 ($x, $y) = ($map->enter_x, $map->enter_y) 2460 ($x, $y) = ($map->enter_x, $map->enter_y)
1841 if $x <=0 && $y <= 0; 2461 if $x <=0 && $y <= 0;
1842 2462
1843 $map->load; 2463 $map->load;
1844 $map->load_diag; 2464 $map->load_neighbours;
1845 2465
1846 return unless $self->contr->active; 2466 return unless $self->contr->active;
1847 $self->activate_recursive; 2467 $self->activate_recursive;
1848 2468
1849 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2469 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1850 $self->enter_map ($map, $x, $y); 2470 $self->enter_map ($map, $x, $y);
1851} 2471}
1852 2472
1853cf::player->attach ( 2473=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1854 on_logout => sub {
1855 my ($pl) = @_;
1856 2474
1857 # abort map switching before logout 2475Moves the player to the given map-path and coordinates by first freezing
1858 if ($pl->ob->{_link_pos}) { 2476her, loading and preparing them map, calling the provided $check callback
1859 cf::sync_job { 2477that has to return the map if sucecssful, and then unfreezes the player on
1860 $pl->ob->leave_link 2478the new (success) or old (failed) map position. In either case, $done will
1861 }; 2479be called at the end of this process.
1862 }
1863 },
1864 on_login => sub {
1865 my ($pl) = @_;
1866 2480
1867 # try to abort aborted map switching on player login :)
1868 # should happen only on crashes
1869 if ($pl->ob->{_link_pos}) {
1870 $pl->ob->enter_link;
1871 (async {
1872 $pl->ob->reply (undef,
1873 "There was an internal problem at your last logout, "
1874 . "the server will try to bring you to your intended destination in a second.",
1875 cf::NDI_RED);
1876 # we need this sleep as the login has a concurrent enter_exit running
1877 # and this sleep increases chances of the player not ending up in scorn
1878 Coro::Timer::sleep 1;
1879 $pl->ob->leave_link;
1880 })->prio (2);
1881 }
1882 },
1883);
1884
1885=item $player_object->goto ($path, $x, $y)
1886
1887=cut 2481=cut
2482
2483our $GOTOGEN;
1888 2484
1889sub cf::object::player::goto { 2485sub cf::object::player::goto {
1890 my ($self, $path, $x, $y) = @_; 2486 my ($self, $path, $x, $y, $check, $done) = @_;
2487
2488 # do generation counting so two concurrent goto's will be executed in-order
2489 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1891 2490
1892 $self->enter_link; 2491 $self->enter_link;
1893 2492
1894 (async { 2493 (async {
2494 $Coro::current->{desc} = "player::goto $path $x $y";
2495
2496 # *tag paths override both path and x|y
2497 if ($path =~ /^\*(.*)$/) {
2498 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2499 my $ob = $obs[rand @obs];
2500
2501 # see if we actually can go there
2502 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2503 $ob = $obs[rand @obs];
2504 } else {
2505 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2506 }
2507 # else put us there anyways for now #d#
2508
2509 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2510 } else {
2511 ($path, $x, $y) = (undef, undef, undef);
2512 }
2513 }
2514
1895 my $map = eval { 2515 my $map = eval {
1896 my $map = cf::map::find $path; 2516 my $map = defined $path ? cf::map::find $path : undef;
2517
2518 if ($map) {
1897 $map = $map->customise_for ($self) if $map; 2519 $map = $map->customise_for ($self);
2520 $map = $check->($map) if $check && $map;
2521 } else {
2522 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2523 }
2524
1898 $map 2525 $map
2526 };
2527
2528 if ($@) {
2529 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2530 LOG llevError | logBacktrace, Carp::longmess $@;
1899 } or 2531 }
1900 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1901 2532
2533 if ($gen == $self->{_goto_generation}) {
2534 delete $self->{_goto_generation};
1902 $self->leave_link ($map, $x, $y); 2535 $self->leave_link ($map, $x, $y);
2536 }
2537
2538 $done->() if $done;
1903 })->prio (1); 2539 })->prio (1);
1904} 2540}
1905 2541
1906=item $player_object->enter_exit ($exit_object) 2542=item $player_object->enter_exit ($exit_object)
1907 2543
… …
1946 2582
1947 $rmp->{random_seed} ||= $exit->random_seed; 2583 $rmp->{random_seed} ||= $exit->random_seed;
1948 2584
1949 my $data = cf::to_json $rmp; 2585 my $data = cf::to_json $rmp;
1950 my $md5 = Digest::MD5::md5_hex $data; 2586 my $md5 = Digest::MD5::md5_hex $data;
1951 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2587 my $meta = "$RANDOMDIR/$md5.meta";
1952 2588
1953 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2589 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1954 aio_write $fh, 0, (length $data), $data, 0; 2590 aio_write $fh, 0, (length $data), $data, 0;
1955 undef $fh; 2591 undef $fh;
1956 aio_rename "$meta~", $meta; 2592 aio_rename "$meta~", $meta;
… …
1965 2601
1966 return unless $self->type == cf::PLAYER; 2602 return unless $self->type == cf::PLAYER;
1967 2603
1968 if ($exit->slaying eq "/!") { 2604 if ($exit->slaying eq "/!") {
1969 #TODO: this should de-fi-ni-te-ly not be a sync-job 2605 #TODO: this should de-fi-ni-te-ly not be a sync-job
2606 # the problem is that $exit might not survive long enough
2607 # so it needs to be done right now, right here
1970 cf::sync_job { prepare_random_map $exit }; 2608 cf::sync_job { prepare_random_map $exit };
1971 } 2609 }
1972 2610
1973 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2611 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1974 my $hp = $exit->stats->hp; 2612 my $hp = $exit->stats->hp;
1975 my $sp = $exit->stats->sp; 2613 my $sp = $exit->stats->sp;
1976 2614
1977 $self->enter_link; 2615 $self->enter_link;
1978 2616
2617 # if exit is damned, update players death & WoR home-position
2618 $self->contr->savebed ($slaying, $hp, $sp)
2619 if $exit->flag (FLAG_DAMNED);
2620
1979 (async { 2621 (async {
2622 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2623
1980 $self->deactivate_recursive; # just to be sure 2624 $self->deactivate_recursive; # just to be sure
1981 unless (eval { 2625 unless (eval {
1982 $self->goto ($slaying, $hp, $sp); 2626 $self->goto ($slaying, $hp, $sp);
1983 2627
1984 1; 2628 1;
1985 }) { 2629 }) {
1986 $self->message ("Something went wrong deep within the crossfire server. " 2630 $self->message ("Something went wrong deep within the crossfire server. "
1987 . "I'll try to bring you back to the map you were before. " 2631 . "I'll try to bring you back to the map you were before. "
1988 . "Please report this to the dungeon master!", 2632 . "Please report this to the dungeon master!",
1989 cf::NDI_UNIQUE | cf::NDI_RED); 2633 cf::NDI_UNIQUE | cf::NDI_RED);
1990 2634
1991 warn "ERROR in enter_exit: $@"; 2635 warn "ERROR in enter_exit: $@";
1992 $self->leave_link; 2636 $self->leave_link;
1993 } 2637 }
1994 })->prio (1); 2638 })->prio (1);
… …
2010 2654
2011 utf8::encode $text; 2655 utf8::encode $text;
2012 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2656 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2013} 2657}
2014 2658
2659=item $client->send_msg ($channel, $msg, $color, [extra...])
2660
2661Send a drawinfo or msg packet to the client, formatting the msg for the
2662client if neccessary. C<$type> should be a string identifying the type of
2663the message, with C<log> being the default. If C<$color> is negative, suppress
2664the message unless the client supports the msg packet.
2665
2666=cut
2667
2668our %CHANNEL = (
2669 "c/identify" => {
2670 id => "infobox",
2671 title => "Identify",
2672 reply => undef,
2673 tooltip => "Items recently identified",
2674 },
2675 "c/examine" => {
2676 id => "infobox",
2677 title => "Examine",
2678 reply => undef,
2679 tooltip => "Signs and other items you examined",
2680 },
2681 "c/lookat" => {
2682 id => "infobox",
2683 title => "Look",
2684 reply => undef,
2685 tooltip => "What you saw there",
2686 },
2687);
2688
2689sub cf::client::send_msg {
2690 my ($self, $channel, $msg, $color, @extra) = @_;
2691
2692 $msg = $self->pl->expand_cfpod ($msg);
2693
2694 $color &= cf::NDI_CLIENT_MASK; # just in case...
2695
2696 # check predefined channels, for the benefit of C
2697 if ($CHANNEL{$channel}) {
2698 $channel = $CHANNEL{$channel};
2699
2700 $self->ext_msg (channel_info => $channel)
2701 if $self->can_msg;
2702
2703 $channel = $channel->{id};
2704
2705 } elsif (ref $channel) {
2706 # send meta info to client, if not yet sent
2707 unless (exists $self->{channel}{$channel->{id}}) {
2708 $self->{channel}{$channel->{id}} = $channel;
2709 $self->ext_msg (channel_info => $channel)
2710 if $self->can_msg;
2711 }
2712
2713 $channel = $channel->{id};
2714 }
2715
2716 return unless @extra || length $msg;
2717
2718 if ($self->can_msg) {
2719 # default colour, mask it out
2720 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2721 if $color & cf::NDI_DEF;
2722
2723 $self->send_packet ("msg " . $self->{json_coder}->encode (
2724 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2725 } else {
2726 if ($color >= 0) {
2727 # replace some tags by gcfclient-compatible ones
2728 for ($msg) {
2729 1 while
2730 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2731 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2732 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2733 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2734 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2735 }
2736
2737 $color &= cf::NDI_COLOR_MASK;
2738
2739 utf8::encode $msg;
2740
2741 if (0 && $msg =~ /\[/) {
2742 # COMMAND/INFO
2743 $self->send_packet ("drawextinfo $color 10 8 $msg")
2744 } else {
2745 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2746 $self->send_packet ("drawinfo $color $msg")
2747 }
2748 }
2749 }
2750}
2751
2015=item $client->ext_event ($type, %msg) 2752=item $client->ext_msg ($type, @msg)
2016 2753
2017Sends an exti event to the client. 2754Sends an ext event to the client.
2018 2755
2019=cut 2756=cut
2020 2757
2021sub cf::client::ext_event($$%) { 2758sub cf::client::ext_msg($$@) {
2022 my ($self, $type, %msg) = @_; 2759 my ($self, $type, @msg) = @_;
2023 2760
2761 if ($self->extcmd == 2) {
2762 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2763 } elsif ($self->extcmd == 1) { # TODO: remove
2024 $msg{msgtype} = "event_$type"; 2764 push @msg, msgtype => "event_$type";
2025 $self->send_packet ("ext " . cf::to_json \%msg); 2765 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2766 }
2767}
2768
2769=item $client->ext_reply ($msgid, @msg)
2770
2771Sends an ext reply to the client.
2772
2773=cut
2774
2775sub cf::client::ext_reply($$@) {
2776 my ($self, $id, @msg) = @_;
2777
2778 if ($self->extcmd == 2) {
2779 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2780 } elsif ($self->extcmd == 1) {
2781 #TODO: version 1, remove
2782 unshift @msg, msgtype => "reply", msgid => $id;
2783 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2784 }
2026} 2785}
2027 2786
2028=item $success = $client->query ($flags, "text", \&cb) 2787=item $success = $client->query ($flags, "text", \&cb)
2029 2788
2030Queues a query to the client, calling the given callback with 2789Queues a query to the client, calling the given callback with
2031the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2790the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2032C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2791C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2033 2792
2034Queries can fail, so check the return code. Or don't, as queries will become 2793Queries can fail, so check the return code. Or don't, as queries will
2035reliable at some point in the future. 2794become reliable at some point in the future.
2036 2795
2037=cut 2796=cut
2038 2797
2039sub cf::client::query { 2798sub cf::client::query {
2040 my ($self, $flags, $text, $cb) = @_; 2799 my ($self, $flags, $text, $cb) = @_;
… …
2048 utf8::encode $text; 2807 utf8::encode $text;
2049 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2808 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2050 2809
2051 $self->send_packet ($self->{query_queue}[0][0]) 2810 $self->send_packet ($self->{query_queue}[0][0])
2052 if @{ $self->{query_queue} } == 1; 2811 if @{ $self->{query_queue} } == 1;
2812
2813 1
2053} 2814}
2054 2815
2055cf::client->attach ( 2816cf::client->attach (
2817 on_connect => sub {
2818 my ($ns) = @_;
2819
2820 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2821 },
2056 on_reply => sub { 2822 on_reply => sub {
2057 my ($ns, $msg) = @_; 2823 my ($ns, $msg) = @_;
2058 2824
2059 # this weird shuffling is so that direct followup queries 2825 # this weird shuffling is so that direct followup queries
2060 # get handled first 2826 # get handled first
… …
2072 } else { 2838 } else {
2073 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2839 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2074 } 2840 }
2075 } 2841 }
2076 }, 2842 },
2843 on_exticmd => sub {
2844 my ($ns, $buf) = @_;
2845
2846 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2847
2848 if (ref $msg) {
2849 my ($type, $reply, @payload) =
2850 "ARRAY" eq ref $msg
2851 ? @$msg
2852 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2853
2854 my @reply;
2855
2856 if (my $cb = $EXTICMD{$type}) {
2857 @reply = $cb->($ns, @payload);
2858 }
2859
2860 $ns->ext_reply ($reply, @reply)
2861 if $reply;
2862
2863 } else {
2864 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2865 }
2866
2867 cf::override;
2868 },
2077); 2869);
2078 2870
2079=item $client->async (\&cb) 2871=item $client->async (\&cb)
2080 2872
2081Create a new coroutine, running the specified callback. The coroutine will 2873Create a new coroutine, running the specified callback. The coroutine will
… …
2122our $safe = new Safe "safe"; 2914our $safe = new Safe "safe";
2123our $safe_hole = new Safe::Hole; 2915our $safe_hole = new Safe::Hole;
2124 2916
2125$SIG{FPE} = 'IGNORE'; 2917$SIG{FPE} = 'IGNORE';
2126 2918
2127$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2919$safe->permit_only (Opcode::opset qw(
2920 :base_core :base_mem :base_orig :base_math
2921 grepstart grepwhile mapstart mapwhile
2922 sort time
2923));
2128 2924
2129# here we export the classes and methods available to script code 2925# here we export the classes and methods available to script code
2130 2926
2131=pod 2927=pod
2132 2928
2133The following functions and methods are available within a safe environment: 2929The following functions and methods are available within a safe environment:
2134 2930
2135 cf::object contr pay_amount pay_player map 2931 cf::object
2932 contr pay_amount pay_player map x y force_find force_add destroy
2933 insert remove name archname title slaying race decrease_ob_nr
2934
2136 cf::object::player player 2935 cf::object::player
2137 cf::player peaceful 2936 player
2138 cf::map trigger 2937
2938 cf::player
2939 peaceful
2940
2941 cf::map
2942 trigger
2139 2943
2140=cut 2944=cut
2141 2945
2142for ( 2946for (
2143 ["cf::object" => qw(contr pay_amount pay_player map)], 2947 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2948 insert remove inv name archname title slaying race
2949 decrease_ob_nr destroy)],
2144 ["cf::object::player" => qw(player)], 2950 ["cf::object::player" => qw(player)],
2145 ["cf::player" => qw(peaceful)], 2951 ["cf::player" => qw(peaceful)],
2146 ["cf::map" => qw(trigger)], 2952 ["cf::map" => qw(trigger)],
2147) { 2953) {
2148 no strict 'refs'; 2954 no strict 'refs';
… …
2219=back 3025=back
2220 3026
2221=cut 3027=cut
2222 3028
2223############################################################################# 3029#############################################################################
2224
2225=head2 EXTENSION DATABASE SUPPORT
2226
2227Crossfire maintains a very simple database for extension use. It can
2228currently store anything that can be serialised using Storable, which
2229excludes objects.
2230
2231The parameter C<$family> should best start with the name of the extension
2232using it, it should be unique.
2233
2234=over 4
2235
2236=item $value = cf::db_get $family => $key
2237
2238Returns a single value from the database.
2239
2240=item cf::db_put $family => $key => $value
2241
2242Stores the given C<$value> in the family.
2243
2244=cut
2245
2246our $DB;
2247
2248sub db_init {
2249 unless ($DB) {
2250 $DB = BDB::db_create $DB_ENV;
2251
2252 cf::sync_job {
2253 eval {
2254 $DB->set_flags (BDB::CHKSUM);
2255
2256 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2257 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2258 cf::cleanup "db_open(db): $!" if $!;
2259 };
2260 cf::cleanup "db_open(db): $@" if $@;
2261 };
2262
2263 my $path = cf::localdir . "/database.pst";
2264 if (stat $path) {
2265 cf::sync_job {
2266 my $pst = Storable::retrieve $path;
2267
2268 cf::db_put (board => data => $pst->{board});
2269 cf::db_put (guildrules => data => $pst->{guildrules});
2270 cf::db_put (rent => balance => $pst->{rent}{balance});
2271 BDB::db_env_txn_checkpoint $DB_ENV;
2272
2273 unlink $path;
2274 };
2275 }
2276 }
2277}
2278
2279sub db_get($$) {
2280 my $key = "$_[0]/$_[1]";
2281
2282 cf::sync_job {
2283 BDB::db_get $DB, undef, $key, my $data;
2284
2285 $! ? ()
2286 : Compress::LZF::sthaw $data
2287 }
2288}
2289
2290sub db_put($$$) {
2291 BDB::dbreq_pri 4;
2292 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2293}
2294
2295#############################################################################
2296# the server's init and main functions 3030# the server's init and main functions
2297 3031
2298sub load_facedata { 3032sub load_facedata($) {
2299 my $path = sprintf "%s/facedata", cf::datadir; 3033 my ($path) = @_;
3034
3035 # HACK to clear player env face cache, we need some signal framework
3036 # for this (global event?)
3037 %ext::player_env::MUSIC_FACE_CACHE = ();
3038
3039 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2300 3040
2301 warn "loading facedata from $path\n"; 3041 warn "loading facedata from $path\n";
2302 3042
2303 my $faces; 3043 my $facedata;
2304 0 < aio_load $path, $faces 3044 0 < aio_load $path, $facedata
2305 or die "$path: $!"; 3045 or die "$path: $!";
2306 3046
2307 Coro::cede;
2308 $faces = Storable::thaw $faces; 3047 $facedata = Coro::Storable::thaw $facedata;
2309 Coro::cede;
2310 3048
2311 my $meta = delete $faces->{""};
2312 $meta->{version} == 1 3049 $facedata->{version} == 2
2313 or cf::cleanup "$path: version mismatch, cannot proceed."; 3050 or cf::cleanup "$path: version mismatch, cannot proceed.";
2314 3051
3052 # patch in the exptable
3053 $facedata->{resource}{"res/exp_table"} = {
3054 type => FT_RSRC,
3055 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3056 };
3057 cf::cede_to_tick;
3058
3059 {
3060 my $faces = $facedata->{faceinfo};
3061
2315 while (my ($face, $info) = each %$faces) { 3062 while (my ($face, $info) = each %$faces) {
2316 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3063 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2317 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3064 cf::face::set_visibility $idx, $info->{visibility};
3065 cf::face::set_magicmap $idx, $info->{magicmap};
2318 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3066 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2319 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3067 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2320 Coro::cede;
2321 }
2322 3068
3069 cf::cede_to_tick;
3070 }
3071
2323 while (my ($face, $info) = each %$faces) { 3072 while (my ($face, $info) = each %$faces) {
2324 next unless $info->{smooth}; 3073 next unless $info->{smooth};
2325 my $idx = cf::face::find $face 3074 my $idx = cf::face::find $face
2326 or next; 3075 or next;
2327 if (my $smooth = cf::face::find $info->{smooth}) { 3076 if (my $smooth = cf::face::find $info->{smooth}) {
2328 cf::face::set_smooth $idx, $smooth; 3077 cf::face::set_smooth $idx, $smooth;
3078 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2329 } else { 3079 } else {
2330 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3080 warn "smooth face '$info->{smooth}' not found for face '$face'";
2331 } 3081 }
2332 Coro::cede; 3082
3083 cf::cede_to_tick;
3084 }
3085 }
3086
3087 {
3088 my $anims = $facedata->{animinfo};
3089
3090 while (my ($anim, $info) = each %$anims) {
3091 cf::anim::set $anim, $info->{frames}, $info->{facings};
3092 cf::cede_to_tick;
3093 }
3094
3095 cf::anim::invalidate_all; # d'oh
3096 }
3097
3098 {
3099 # TODO: for gcfclient pleasure, we should give resources
3100 # that gcfclient doesn't grok a >10000 face index.
3101 my $res = $facedata->{resource};
3102
3103 my $soundconf = delete $res->{"res/sound.conf"};
3104
3105 while (my ($name, $info) = each %$res) {
3106 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3107 my $data;
3108
3109 if ($info->{type} & 1) {
3110 # prepend meta info
3111
3112 my $meta = $enc->encode ({
3113 name => $name,
3114 %{ $info->{meta} || {} },
3115 });
3116
3117 $data = pack "(w/a*)*", $meta, $info->{data};
3118 } else {
3119 $data = $info->{data};
3120 }
3121
3122 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3123 cf::face::set_type $idx, $info->{type};
3124
3125 cf::cede_to_tick;
3126 }
3127
3128 if ($soundconf) {
3129 $soundconf = $enc->decode (delete $soundconf->{data});
3130
3131 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3132 my $sound = $soundconf->{compat}[$_]
3133 or next;
3134
3135 my $face = cf::face::find "sound/$sound->[1]";
3136 cf::sound::set $sound->[0] => $face;
3137 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3138 }
3139
3140 while (my ($k, $v) = each %{$soundconf->{event}}) {
3141 my $face = cf::face::find "sound/$v";
3142 cf::sound::set $k => $face;
3143 }
3144 }
2333 } 3145 }
2334 3146
2335 1 3147 1
2336} 3148}
2337 3149
3150register_exticmd fx_want => sub {
3151 my ($ns, $want) = @_;
3152
3153 while (my ($k, $v) = each %$want) {
3154 $ns->fx_want ($k, $v);
3155 }
3156};
3157
3158sub reload_regions {
3159 # HACK to clear player env face cache, we need some signal framework
3160 # for this (global event?)
3161 %ext::player_env::MUSIC_FACE_CACHE = ();
3162
3163 load_resource_file "$MAPDIR/regions"
3164 or die "unable to load regions file\n";
3165
3166 for (cf::region::list) {
3167 $_->{match} = qr/$_->{match}/
3168 if exists $_->{match};
3169 }
3170}
3171
3172sub reload_facedata {
3173 load_facedata "$DATADIR/facedata"
3174 or die "unable to load facedata\n";
3175}
3176
3177sub reload_archetypes {
3178 load_resource_file "$DATADIR/archetypes"
3179 or die "unable to load archetypes\n";
3180 #d# NEED to laod twice to resolve forward references
3181 # this really needs to be done in an extra post-pass
3182 # (which needs to be synchronous, so solve it differently)
3183 load_resource_file "$DATADIR/archetypes"
3184 or die "unable to load archetypes\n";
3185}
3186
3187sub reload_treasures {
3188 load_resource_file "$DATADIR/treasures"
3189 or die "unable to load treasurelists\n";
3190}
3191
2338sub reload_resources { 3192sub reload_resources {
2339 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 3193 warn "reloading resource files...\n";
2340 or die "unable to load regions file\n";#d# 3194
3195 reload_regions;
2341 load_facedata 3196 reload_facedata;
2342 or die "unable to load facedata\n";#d# 3197 #reload_archetypes;#d#
3198 reload_archetypes;
3199 reload_treasures;
3200
3201 warn "finished reloading resource files\n";
2343} 3202}
2344 3203
2345sub init { 3204sub init {
2346 reload_resources; 3205 reload_resources;
2347} 3206}
2348 3207
2349sub cfg_load { 3208sub reload_config {
2350 open my $fh, "<:utf8", cf::confdir . "/config" 3209 open my $fh, "<:utf8", "$CONFDIR/config"
2351 or return; 3210 or return;
2352 3211
2353 local $/; 3212 local $/;
2354 *CFG = YAML::Syck::Load <$fh>; 3213 *CFG = YAML::Syck::Load <$fh>;
2355 3214
… …
2370sub main { 3229sub main {
2371 # we must not ever block the main coroutine 3230 # we must not ever block the main coroutine
2372 local $Coro::idle = sub { 3231 local $Coro::idle = sub {
2373 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3232 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2374 (async { 3233 (async {
3234 $Coro::current->{desc} = "IDLE BUG HANDLER";
2375 Event::one_event; 3235 Event::one_event;
2376 })->prio (Coro::PRIO_MAX); 3236 })->prio (Coro::PRIO_MAX);
2377 }; 3237 };
2378 3238
2379 cfg_load; 3239 reload_config;
2380 db_init; 3240 db_init;
2381 load_extensions; 3241 load_extensions;
2382 3242
2383 $TICK_WATCHER->start; 3243 $TICK_WATCHER->start;
2384 Event::loop; 3244 Event::loop;
… …
2400 }, 3260 },
2401 ); 3261 );
2402 } 3262 }
2403} 3263}
2404 3264
3265sub write_runtime {
3266 my $runtime = "$LOCALDIR/runtime";
3267
3268 # first touch the runtime file to show we are still running:
3269 # the fsync below can take a very very long time.
3270
3271 IO::AIO::aio_utime $runtime, undef, undef;
3272
3273 my $guard = cf::lock_acquire "write_runtime";
3274
3275 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3276 or return;
3277
3278 my $value = $cf::RUNTIME + 90 + 10;
3279 # 10 is the runtime save interval, for a monotonic clock
3280 # 60 allows for the watchdog to kill the server.
3281
3282 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3283 and return;
3284
3285 # always fsync - this file is important
3286 aio_fsync $fh
3287 and return;
3288
3289 # touch it again to show we are up-to-date
3290 aio_utime $fh, undef, undef;
3291
3292 close $fh
3293 or return;
3294
3295 aio_rename "$runtime~", $runtime
3296 and return;
3297
3298 warn "runtime file written.\n";
3299
3300 1
3301}
3302
2405sub emergency_save() { 3303sub emergency_save() {
2406 my $freeze_guard = cf::freeze_mainloop; 3304 my $freeze_guard = cf::freeze_mainloop;
2407 3305
2408 warn "enter emergency perl save\n"; 3306 warn "enter emergency perl save\n";
2409 3307
… …
2413 # and maps saved/destroyed asynchronously. 3311 # and maps saved/destroyed asynchronously.
2414 warn "begin emergency player save\n"; 3312 warn "begin emergency player save\n";
2415 for my $login (keys %cf::PLAYER) { 3313 for my $login (keys %cf::PLAYER) {
2416 my $pl = $cf::PLAYER{$login} or next; 3314 my $pl = $cf::PLAYER{$login} or next;
2417 $pl->valid or next; 3315 $pl->valid or next;
3316 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2418 $pl->save; 3317 $pl->save;
2419 } 3318 }
2420 warn "end emergency player save\n"; 3319 warn "end emergency player save\n";
2421 3320
2422 warn "begin emergency map save\n"; 3321 warn "begin emergency map save\n";
… …
2440 3339
2441 warn Carp::longmess "post_cleanup backtrace" 3340 warn Carp::longmess "post_cleanup backtrace"
2442 if $make_core; 3341 if $make_core;
2443} 3342}
2444 3343
2445sub reload() { 3344sub do_reload_perl() {
2446 # can/must only be called in main 3345 # can/must only be called in main
2447 if ($Coro::current != $Coro::main) { 3346 if ($Coro::current != $Coro::main) {
2448 warn "can only reload from main coroutine"; 3347 warn "can only reload from main coroutine";
2449 return; 3348 return;
2450 } 3349 }
… …
2484 %EXT_CORO = (); 3383 %EXT_CORO = ();
2485 3384
2486 warn "removing commands"; 3385 warn "removing commands";
2487 %COMMAND = (); 3386 %COMMAND = ();
2488 3387
2489 warn "removing ext commands"; 3388 warn "removing ext/exti commands";
2490 %EXTCMD = (); 3389 %EXTCMD = ();
3390 %EXTICMD = ();
2491 3391
2492 warn "unloading/nuking all extensions"; 3392 warn "unloading/nuking all extensions";
2493 for my $pkg (@EXTS) { 3393 for my $pkg (@EXTS) {
2494 warn "... unloading $pkg"; 3394 warn "... unloading $pkg";
2495 3395
… …
2525 Symbol::delete_package "safe::$_" 3425 Symbol::delete_package "safe::$_"
2526 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3426 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2527 3427
2528 warn "unloading cf.pm \"a bit\""; 3428 warn "unloading cf.pm \"a bit\"";
2529 delete $INC{"cf.pm"}; 3429 delete $INC{"cf.pm"};
3430 delete $INC{"cf/pod.pm"};
2530 3431
2531 # don't, removes xs symbols, too, 3432 # don't, removes xs symbols, too,
2532 # and global variables created in xs 3433 # and global variables created in xs
2533 #Symbol::delete_package __PACKAGE__; 3434 #Symbol::delete_package __PACKAGE__;
2534 3435
… …
2537 warn "reloading cf.pm"; 3438 warn "reloading cf.pm";
2538 require cf; 3439 require cf;
2539 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3440 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2540 3441
2541 warn "loading config and database again"; 3442 warn "loading config and database again";
2542 cf::cfg_load; 3443 cf::reload_config;
2543 3444
2544 warn "loading extensions"; 3445 warn "loading extensions";
2545 cf::load_extensions; 3446 cf::load_extensions;
2546 3447
2547 warn "reattaching attachments to objects/players"; 3448 warn "reattaching attachments to objects/players";
… …
2549 warn "reattaching attachments to maps"; 3450 warn "reattaching attachments to maps";
2550 reattach $_ for values %MAP; 3451 reattach $_ for values %MAP;
2551 warn "reattaching attachments to players"; 3452 warn "reattaching attachments to players";
2552 reattach $_ for values %PLAYER; 3453 reattach $_ for values %PLAYER;
2553 3454
2554 warn "loading reloadable resources";
2555 reload_resources;
2556
2557 warn "leaving sync_job"; 3455 warn "leaving sync_job";
2558 3456
2559 1 3457 1
2560 } or do { 3458 } or do {
2561 warn $@; 3459 warn $@;
… …
2566 warn "reloaded"; 3464 warn "reloaded";
2567}; 3465};
2568 3466
2569our $RELOAD_WATCHER; # used only during reload 3467our $RELOAD_WATCHER; # used only during reload
2570 3468
3469sub reload_perl() {
3470 # doing reload synchronously and two reloads happen back-to-back,
3471 # coro crashes during coro_state_free->destroy here.
3472
3473 $RELOAD_WATCHER ||= Event->timer (
3474 reentrant => 0,
3475 after => 0,
3476 data => WF_AUTOCANCEL,
3477 cb => sub {
3478 do_reload_perl;
3479 undef $RELOAD_WATCHER;
3480 },
3481 );
3482}
3483
2571register_command "reload" => sub { 3484register_command "reload" => sub {
2572 my ($who, $arg) = @_; 3485 my ($who, $arg) = @_;
2573 3486
2574 if ($who->flag (FLAG_WIZ)) { 3487 if ($who->flag (FLAG_WIZ)) {
2575 $who->message ("reloading server."); 3488 $who->message ("reloading server.");
2576 3489 async {
2577 # doing reload synchronously and two reloads happen back-to-back, 3490 $Coro::current->{desc} = "perl_reload";
2578 # coro crashes during coro_state_free->destroy here.
2579
2580 $RELOAD_WATCHER ||= Event->timer (
2581 reentrant => 0,
2582 after => 0,
2583 data => WF_AUTOCANCEL,
2584 cb => sub {
2585 reload; 3491 reload_perl;
2586 undef $RELOAD_WATCHER;
2587 },
2588 ); 3492 };
2589 } 3493 }
2590}; 3494};
2591 3495
2592unshift @INC, $LIBDIR; 3496unshift @INC, $LIBDIR;
2593 3497
2594my $bug_warning = 0; 3498my $bug_warning = 0;
3499
3500our @WAIT_FOR_TICK;
3501our @WAIT_FOR_TICK_BEGIN;
3502
3503sub wait_for_tick {
3504 return unless $TICK_WATCHER->is_active;
3505 return if $Coro::current == $Coro::main;
3506
3507 my $signal = new Coro::Signal;
3508 push @WAIT_FOR_TICK, $signal;
3509 $signal->wait;
3510}
3511
3512sub wait_for_tick_begin {
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_BEGIN, $signal;
3518 $signal->wait;
3519}
2595 3520
2596$TICK_WATCHER = Event->timer ( 3521$TICK_WATCHER = Event->timer (
2597 reentrant => 0, 3522 reentrant => 0,
2598 parked => 1, 3523 parked => 1,
2599 prio => 0, 3524 prio => 0,
… …
2604 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3529 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2605 unless ++$bug_warning > 10; 3530 unless ++$bug_warning > 10;
2606 return; 3531 return;
2607 } 3532 }
2608 3533
2609 $NOW = Event::time; 3534 $NOW = $tick_start = Event::time;
2610 3535
2611 cf::server_tick; # one server iteration 3536 cf::server_tick; # one server iteration
3537
2612 $RUNTIME += $TICK; 3538 $RUNTIME += $TICK;
2613 $NEXT_TICK += $TICK; 3539 $NEXT_TICK += $TICK;
2614 3540
2615 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3541 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2616 $NEXT_RUNTIME_WRITE = $NOW + 10; 3542 $NEXT_RUNTIME_WRITE = $NOW + 10;
2617 Coro::async_pool { 3543 Coro::async_pool {
3544 $Coro::current->{desc} = "runtime saver";
2618 write_runtime 3545 write_runtime
2619 or warn "ERROR: unable to write runtime file: $!"; 3546 or warn "ERROR: unable to write runtime file: $!";
2620 }; 3547 };
2621 } 3548 }
2622 3549
2623 $WAIT_FOR_TICK->broadcast; 3550 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2624 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 3551 $sig->send;
3552 }
3553 while (my $sig = shift @WAIT_FOR_TICK) {
3554 $sig->send;
3555 }
2625 3556
2626# my $AFTER = Event::time; 3557 $NOW = Event::time;
2627# warn $AFTER - $NOW;#d#
2628 3558
2629 # if we are delayed by four ticks or more, skip them all 3559 # if we are delayed by four ticks or more, skip them all
2630 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3560 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2631 3561
2632 $TICK_WATCHER->at ($NEXT_TICK); 3562 $TICK_WATCHER->at ($NEXT_TICK);
2633 $TICK_WATCHER->start; 3563 $TICK_WATCHER->start;
3564
3565 $LOAD = ($NOW - $tick_start) / $TICK;
3566 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3567
3568 _post_tick;
2634 }, 3569 },
2635); 3570);
2636 3571
2637{ 3572{
3573 BDB::min_parallel 8;
2638 BDB::max_poll_time $TICK * 0.1; 3574 BDB::max_poll_time $TICK * 0.1;
2639 $BDB_POLL_WATCHER = Event->io ( 3575 $BDB_POLL_WATCHER = Event->io (
2640 reentrant => 0, 3576 reentrant => 0,
2641 fd => BDB::poll_fileno, 3577 fd => BDB::poll_fileno,
2642 poll => 'r', 3578 poll => 'r',
2643 prio => 0, 3579 prio => 0,
2644 data => WF_AUTOCANCEL, 3580 data => WF_AUTOCANCEL,
2645 cb => \&BDB::poll_cb, 3581 cb => \&BDB::poll_cb,
2646 ); 3582 );
2647 BDB::min_parallel 8;
2648 3583
2649 BDB::set_sync_prepare { 3584 BDB::set_sync_prepare {
2650 my $status; 3585 my $status;
2651 my $current = $Coro::current; 3586 my $current = $Coro::current;
2652 ( 3587 (
… …
2661 ) 3596 )
2662 }; 3597 };
2663 3598
2664 unless ($DB_ENV) { 3599 unless ($DB_ENV) {
2665 $DB_ENV = BDB::db_env_create; 3600 $DB_ENV = BDB::db_env_create;
3601 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3602 | BDB::LOG_AUTOREMOVE, 1);
3603 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3604 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2666 3605
2667 cf::sync_job { 3606 cf::sync_job {
2668 eval { 3607 eval {
2669 BDB::db_env_open 3608 BDB::db_env_open
2670 $DB_ENV, 3609 $DB_ENV,
2671 $BDB_ENV_DIR, 3610 $BDBDIR,
2672 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3611 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2673 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3612 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2674 0666; 3613 0666;
2675 3614
2676 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3615 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2677
2678 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2679 $DB_ENV->set_lk_detect;
2680 }; 3616 };
2681 3617
2682 cf::cleanup "db_env_open(db): $@" if $@; 3618 cf::cleanup "db_env_open(db): $@" if $@;
2683 }; 3619 };
2684 } 3620 }
3621
3622 $BDB_DEADLOCK_WATCHER = Event->timer (
3623 after => 3,
3624 interval => 1,
3625 hard => 1,
3626 prio => 0,
3627 data => WF_AUTOCANCEL,
3628 cb => sub {
3629 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3630 },
3631 );
3632 $BDB_CHECKPOINT_WATCHER = Event->timer (
3633 after => 11,
3634 interval => 60,
3635 hard => 1,
3636 prio => 0,
3637 data => WF_AUTOCANCEL,
3638 cb => sub {
3639 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3640 },
3641 );
3642 $BDB_TRICKLE_WATCHER = Event->timer (
3643 after => 5,
3644 interval => 10,
3645 hard => 1,
3646 prio => 0,
3647 data => WF_AUTOCANCEL,
3648 cb => sub {
3649 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3650 },
3651 );
2685} 3652}
2686 3653
2687{ 3654{
2688 IO::AIO::min_parallel 8; 3655 IO::AIO::min_parallel 8;
2689 3656
… …
2692 $AIO_POLL_WATCHER = Event->io ( 3659 $AIO_POLL_WATCHER = Event->io (
2693 reentrant => 0, 3660 reentrant => 0,
2694 data => WF_AUTOCANCEL, 3661 data => WF_AUTOCANCEL,
2695 fd => IO::AIO::poll_fileno, 3662 fd => IO::AIO::poll_fileno,
2696 poll => 'r', 3663 poll => 'r',
2697 prio => 6, 3664 prio => 0,
2698 cb => \&IO::AIO::poll_cb, 3665 cb => \&IO::AIO::poll_cb,
2699 ); 3666 );
2700} 3667}
2701 3668
3669my $_log_backtrace;
3670
3671sub _log_backtrace {
3672 my ($msg, @addr) = @_;
3673
3674 $msg =~ s/\n//;
3675
3676 # limit the # of concurrent backtraces
3677 if ($_log_backtrace < 2) {
3678 ++$_log_backtrace;
3679 async {
3680 $Coro::current->{desc} = "abt $msg";
3681
3682 my @bt = fork_call {
3683 @addr = map { sprintf "%x", $_ } @addr;
3684 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3685 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3686 or die "addr2line: $!";
3687
3688 my @funcs;
3689 my @res = <$fh>;
3690 chomp for @res;
3691 while (@res) {
3692 my ($func, $line) = splice @res, 0, 2, ();
3693 push @funcs, "[$func] $line";
3694 }
3695
3696 @funcs
3697 };
3698
3699 LOG llevInfo, "[ABT] $msg\n";
3700 LOG llevInfo, "[ABT] $_\n" for @bt;
3701 --$_log_backtrace;
3702 };
3703 } else {
3704 LOG llevInfo, "[ABT] $msg\n";
3705 LOG llevInfo, "[ABT] [suppressed]\n";
3706 }
3707}
3708
3709# load additional modules
3710use cf::pod;
3711
2702END { cf::emergency_save } 3712END { cf::emergency_save }
2703 3713
27041 37141
2705 3715

Diff Legend

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