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.224 by root, Mon Mar 12 21:42:12 2007 UTC vs.
Revision 1.385 by root, Fri Oct 12 19:13:26 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 IO::AIO 2.32 ();
27use YAML::Syck (); 31use YAML::Syck ();
32use IO::AIO 2.51 ();
28use Time::HiRes; 33use Time::HiRes;
29use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 ();
30 36
37# configure various modules to our taste
38#
39$Storable::canonical = 1; # reduce rsync transfers
31Coro::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
32Compress::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
42
33$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
34
35sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
36 44
37# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
38$YAML::Syck::ImplicitUnicode = 1; 46$YAML::Syck::ImplicitUnicode = 1;
39 47
40$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
41 49
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51
42our %COMMAND = (); 52our %COMMAND = ();
43our %COMMAND_TIME = (); 53our %COMMAND_TIME = ();
44 54
45our @EXTS = (); # list of extension package names 55our @EXTS = (); # list of extension package names
46our %EXTCMD = (); 56our %EXTCMD = ();
57our %EXTICMD = ();
47our %EXT_CORO = (); # coroutines bound to extensions 58our %EXT_CORO = (); # coroutines bound to extensions
48our %EXT_MAP = (); # pluggable maps 59our %EXT_MAP = (); # pluggable maps
49 60
50our $RELOAD; # number of reloads so far 61our $RELOAD; # number of reloads so far
51our @EVENT; 62our @EVENT;
52our $LIBDIR = datadir . "/ext";
53 63
54our $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(!)
55our $TICK_WATCHER; 77our $TICK_WATCHER;
56our $AIO_POLL_WATCHER; 78our $AIO_POLL_WATCHER;
57our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
58our $NEXT_TICK; 80our $NEXT_TICK;
59our $NOW; 81our $NOW;
60our $USE_FSYNC = 1; # use fsync to write maps - default off 82our $USE_FSYNC = 1; # use fsync to write maps - default off
61 83
62our $BDB_POLL_WATCHER; 84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER;
63our $DB_ENV; 88our $DB_ENV;
64 89
65our %CFG; 90our %CFG;
66 91
67our $UPTIME; $UPTIME ||= time; 92our $UPTIME; $UPTIME ||= time;
68our $RUNTIME; 93our $RUNTIME;
69 94
70our %PLAYER; # all users 95our (%PLAYER, %PLAYER_LOADING); # all users
71our %MAP; # all maps 96our (%MAP, %MAP_LOADING ); # all maps
72our $LINK_MAP; # the special {link} map, which is always available 97our $LINK_MAP; # the special {link} map, which is always available
73our $RANDOM_MAPS = cf::localdir . "/random";
74our $BDB_ENV_DIR = cf::localdir . "/db";
75
76our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
77our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
78 98
79# 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 ∕
80our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
81 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
82binmode STDOUT; 106binmode STDOUT;
83binmode STDERR; 107binmode STDERR;
84 108
85# read virtual server time, if available 109# read virtual server time, if available
86unless ($RUNTIME || !-e cf::localdir . "/runtime") { 110unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
87 open my $fh, "<", cf::localdir . "/runtime" 111 open my $fh, "<", "$LOCALDIR/runtime"
88 or die "unable to read runtime file: $!"; 112 or die "unable to read runtime file: $!";
89 $RUNTIME = <$fh> + 0.; 113 $RUNTIME = <$fh> + 0.;
90} 114}
91 115
92mkdir cf::localdir; 116mkdir $_
93mkdir cf::localdir . "/" . cf::playerdir; 117 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
94mkdir cf::localdir . "/" . cf::tmpdir;
95mkdir cf::localdir . "/" . cf::uniquedir;
96mkdir $RANDOM_MAPS;
97mkdir $BDB_ENV_DIR;
98 118
99our $EMERGENCY_POSITION; 119our $EMERGENCY_POSITION;
100 120
101sub cf::map::normalise; 121sub cf::map::normalise;
102 122
… …
113=item $cf::RUNTIME 133=item $cf::RUNTIME
114 134
115The 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
116every server tick. 136every server tick.
117 137
118=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
119 141
120The perl library directory, where extensions and cf-specific modules can 142Various directories - "/etc", read-only install directory, perl-library
121be 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.
122 146
123=item $cf::NOW 147=item $cf::NOW
124 148
125The time of the last (current) server tick. 149The time of the last (current) server tick.
126 150
127=item $cf::TICK 151=item $cf::TICK
128 152
129The 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.
130 164
131=item %cf::CFG 165=item %cf::CFG
132 166
133Configuration for the server, loaded from C</etc/crossfire/config>, or 167Configuration for the server, loaded from C</etc/crossfire/config>, or
134from wherever your confdir points to. 168from wherever your confdir points to.
135 169
136=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 170=item cf::wait_for_tick, cf::wait_for_tick_begin
137 171
138These 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
139or 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
140processing 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.
141window 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.
142 181
143=back 182=back
144 183
145=cut 184=cut
146 185
147BEGIN { 186BEGIN {
148 *CORE::GLOBAL::warn = sub { 187 *CORE::GLOBAL::warn = sub {
149 my $msg = join "", @_; 188 my $msg = join "", @_;
150 utf8::encode $msg;
151 189
152 $msg .= "\n" 190 $msg .= "\n"
153 unless $msg =~ /\n$/; 191 unless $msg =~ /\n$/;
192
193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
154 194
155 LOG llevError, $msg; 195 LOG llevError, $msg;
156 }; 196 };
157} 197}
158 198
159@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
160@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
161@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
162@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
163@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';
164@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)
165 206
166# 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
167# within the Safe compartment. 208# within the Safe compartment.
168for my $pkg (qw( 209for my $pkg (qw(
169 cf::global cf::attachable 210 cf::global cf::attachable
… …
177} 218}
178 219
179$Event::DIED = sub { 220$Event::DIED = sub {
180 warn "error in event callback: @_"; 221 warn "error in event callback: @_";
181}; 222};
223
224#############################################################################
182 225
183=head2 UTILITY FUNCTIONS 226=head2 UTILITY FUNCTIONS
184 227
185=over 4 228=over 4
186 229
… …
205 $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;
206 $d 249 $d
207 } || "[unable to dump $_[0]: '$@']"; 250 } || "[unable to dump $_[0]: '$@']";
208} 251}
209 252
210use JSON::Syck (); # TODO# replace by JSON::PC once working
211
212=item $ref = cf::from_json $json 253=item $ref = cf::from_json $json
213 254
214Converts a JSON string into the corresponding perl data structure. 255Converts a JSON string into the corresponding perl data structure.
215 256
216=cut
217
218sub from_json($) {
219 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
220 JSON::Syck::Load $_[0]
221}
222
223=item $json = cf::to_json $ref 257=item $json = cf::to_json $ref
224 258
225Converts a perl data structure into its JSON representation. 259Converts a perl data structure into its JSON representation.
226 260
227=cut 261=cut
228 262
229sub to_json($) { 263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
230 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 264
231 JSON::Syck::Dump $_[0] 265sub to_json ($) { $json_coder->encode ($_[0]) }
232} 266sub from_json ($) { $json_coder->decode ($_[0]) }
233 267
234=item cf::lock_wait $string 268=item cf::lock_wait $string
235 269
236Wait until the given lock is available. See cf::lock_acquire. 270Wait until the given lock is available. See cf::lock_acquire.
237 271
… …
240Wait 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
241a 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,
242for example when the coroutine gets canceled), the lock is automatically 276for example when the coroutine gets canceled), the lock is automatically
243returned. 277returned.
244 278
279Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro.
281
245Lock 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
246uses map_find and cf::map::load uses map_load). 283uses map_find and cf::map::load uses map_load).
247 284
285=item $locked = cf::lock_active $string
286
287Return true if the lock is currently active, i.e. somebody has locked it.
288
248=cut 289=cut
249 290
250our %LOCK; 291our %LOCK;
292our %LOCKER;#d#
251 293
252sub lock_wait($) { 294sub lock_wait($) {
253 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#
254 301
255 # wait for lock, if any 302 # wait for lock, if any
256 while ($LOCK{$key}) { 303 while ($LOCK{$key}) {
257 push @{ $LOCK{$key} }, $Coro::current; 304 push @{ $LOCK{$key} }, $Coro::current;
258 Coro::schedule; 305 Coro::schedule;
… …
264 311
265 # wait, to be sure we are not locked 312 # wait, to be sure we are not locked
266 lock_wait $key; 313 lock_wait $key;
267 314
268 $LOCK{$key} = []; 315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
269 317
270 Coro::guard { 318 Coro::guard {
319 delete $LOCKER{$key};#d#
271 # wake up all waiters, to be on the safe side 320 # wake up all waiters, to be on the safe side
272 $_->ready for @{ delete $LOCK{$key} }; 321 $_->ready for @{ delete $LOCK{$key} };
273 } 322 }
323}
324
325sub lock_active($) {
326 my ($key) = @_;
327
328 ! ! $LOCK{$key}
274} 329}
275 330
276sub freeze_mainloop { 331sub freeze_mainloop {
277 return unless $TICK_WATCHER->is_active; 332 return unless $TICK_WATCHER->is_active;
278 333
… …
281 }; 336 };
282 $TICK_WATCHER->stop; 337 $TICK_WATCHER->stop;
283 $guard 338 $guard
284} 339}
285 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
286=item cf::async { BLOCK } 399=item cf::async { BLOCK }
287 400
288Currently the same as Coro::async_pool, meaning you cannot use 401Currently the same as Coro::async_pool, meaning you cannot use
289C<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
290thing you are allowed to do is call C<prio> on it. 403thing you are allowed to do is call C<prio> on it.
… …
293 406
294BEGIN { *async = \&Coro::async_pool } 407BEGIN { *async = \&Coro::async_pool }
295 408
296=item cf::sync_job { BLOCK } 409=item cf::sync_job { BLOCK }
297 410
298The design of crossfire+ requires that the main coro ($Coro::main) is 411The design of Crossfire TRT requires that the main coroutine ($Coro::main)
299always able to handle events or runnable, as crossfire+ is only partly 412is always able to handle events or runnable, as Crossfire TRT is only
300reentrant. 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.
301 415
302If 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
303the given BLOCK in another coroutine while waiting for the result. The 417the given BLOCK in another coroutine while waiting for the result. The
304server 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
305fast or be very important. 419fast or be very important.
… …
308 422
309sub sync_job(&) { 423sub sync_job(&) {
310 my ($job) = @_; 424 my ($job) = @_;
311 425
312 if ($Coro::current == $Coro::main) { 426 if ($Coro::current == $Coro::main) {
427 my $time = Event::time;
428
313 # this is the main coro, too bad, we have to block 429 # this is the main coro, too bad, we have to block
314 # till the operation succeeds, freezing the server :/ 430 # till the operation succeeds, freezing the server :/
315 431
432 LOG llevError, Carp::longmess "sync job";#d#
433
316 # TODO: use suspend/resume instead 434 # TODO: use suspend/resume instead
317 # (but this is cancel-safe) 435 # (but this is cancel-safe)
318 my $freeze_guard = freeze_mainloop; 436 my $freeze_guard = freeze_mainloop;
319 437
320 my $busy = 1; 438 my $busy = 1;
321 my @res; 439 my @res;
322 440
323 (async { 441 (async {
442 $Coro::current->desc ("sync job coro");
324 @res = eval { $job->() }; 443 @res = eval { $job->() };
325 warn $@ if $@; 444 warn $@ if $@;
326 undef $busy; 445 undef $busy;
327 })->prio (Coro::PRIO_MAX); 446 })->prio (Coro::PRIO_MAX);
328 447
329 while ($busy) { 448 while ($busy) {
330 Coro::cede or Event::one_event; 449 Coro::cede or Event::one_event;
331 } 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
332 458
333 wantarray ? @res : $res[0] 459 wantarray ? @res : $res[0]
334 } else { 460 } else {
335 # we are in another coroutine, how wonderful, everything just works 461 # we are in another coroutine, how wonderful, everything just works
336 462
… …
356 $EXT_CORO{$coro+0} = $coro; 482 $EXT_CORO{$coro+0} = $coro;
357 483
358 $coro 484 $coro
359} 485}
360 486
361sub write_runtime { 487=item fork_call { }, $args
362 my $guard = cf::lock_acquire "write_runtime";
363 488
364 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.
365 493
366 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 494=cut
367 or return;
368 495
369 my $value = $cf::RUNTIME + 90 + 10; 496sub fork_call(&@) {
370 # 10 is the runtime save interval, for a monotonic clock 497 my ($cb, @args) = @_;
371 # 60 allows for the watchdog to kill the server.
372 498
373 (aio_write $fh, 0, (length $value), $value, 0) <= 0 499 # we seemingly have to make a local copy of the whole thing,
374 and return; 500 # otherwise perl prematurely frees the stuff :/
501 # TODO: investigate and fix (likely this will be rather laborious)
375 502
376 # always fsync - this file is important 503 my @res = Coro::Util::fork_eval {
377 aio_fsync $fh 504 reset_signals;
378 and return; 505 &$cb
506 }, @args;
379 507
380 close $fh 508 wantarray ? @res : $res[-1]
381 or return; 509}
382 510
383 aio_rename "$runtime~", $runtime 511=item $value = cf::db_get $family => $key
384 and return;
385 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
386 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"
636}
637
638=item cf::datalog type => key => value, ...
639
640Log a datalog packet of the given type with the given key-value pairs.
641
642=cut
643
644sub datalog($@) {
645 my ($type, %kv) = @_;
646 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
387} 647}
388 648
389=back 649=back
390 650
391=cut 651=cut
… …
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#
972
973sub _can_merge {
974 my ($ob1, $ob2) = @_;
975
976 return 1;#d#
977
978 #todo#d# kill yourself and do some recursive checking manually without storable
979 sync_job {
980 my $guard = Coro::Storable::guard;
981 local $Storable::canonical = 1;
982 my $fob1 = Storable::freeze $ob1;
983 my $fob2 = Storable::freeze $ob2;
984 $fob1 eq $fob2
985 }
986}
709 987
710sub reattach { 988sub reattach {
711 # basically do the same as instantiate, without calling instantiate 989 # basically do the same as instantiate, without calling instantiate
712 my ($obj) = @_; 990 my ($obj) = @_;
713 991
… …
760sub object_freezer_save { 1038sub object_freezer_save {
761 my ($filename, $rdata, $objs) = @_; 1039 my ($filename, $rdata, $objs) = @_;
762 1040
763 sync_job { 1041 sync_job {
764 if (length $$rdata) { 1042 if (length $$rdata) {
1043 utf8::decode (my $decname = $filename);
765 warn sprintf "saving %s (%d,%d)\n", 1044 warn sprintf "saving %s (%d,%d)\n",
766 $filename, length $$rdata, scalar @$objs; 1045 $decname, length $$rdata, scalar @$objs;
767 1046
768 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1047 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
769 chmod SAVE_MODE, $fh; 1048 chmod SAVE_MODE, $fh;
770 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1049 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
771 aio_fsync $fh if $cf::USE_FSYNC; 1050 aio_fsync $fh if $cf::USE_FSYNC;
772 close $fh; 1051 close $fh;
773 1052
774 if (@$objs) { 1053 if (@$objs) {
775 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1054 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
776 chmod SAVE_MODE, $fh; 1055 chmod SAVE_MODE, $fh;
777 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1056 my $data = Coro::Storable::blocking_nfreeze { version => 1, objs => $objs };
778 aio_write $fh, 0, (length $data), $data, 0; 1057 aio_write $fh, 0, (length $data), $data, 0;
779 aio_fsync $fh if $cf::USE_FSYNC; 1058 aio_fsync $fh if $cf::USE_FSYNC;
780 close $fh; 1059 close $fh;
781 aio_rename "$filename.pst~", "$filename.pst"; 1060 aio_rename "$filename.pst~", "$filename.pst";
782 } 1061 }
… …
790 } 1069 }
791 } else { 1070 } else {
792 aio_unlink $filename; 1071 aio_unlink $filename;
793 aio_unlink "$filename.pst"; 1072 aio_unlink "$filename.pst";
794 } 1073 }
795 } 1074 };
796} 1075}
797 1076
798sub object_freezer_as_string { 1077sub object_freezer_as_string {
799 my ($rdata, $objs) = @_; 1078 my ($rdata, $objs) = @_;
800 1079
… …
812 or return; 1091 or return;
813 1092
814 unless (aio_stat "$filename.pst") { 1093 unless (aio_stat "$filename.pst") {
815 (aio_load "$filename.pst", $av) >= 0 1094 (aio_load "$filename.pst", $av) >= 0
816 or return; 1095 or return;
817 $av = eval { (Storable::thaw $av)->{objs} };
818 }
819 1096
1097 my $st = eval { Coro::Storable::thaw $av }
1098 || eval { my $guard = Coro::Storable::guard; Storable::thaw $av }; #d# compatibility, remove
1099 $av = $st->{objs};
1100 }
1101
1102 utf8::decode (my $decname = $filename);
820 warn sprintf "loading %s (%d)\n", 1103 warn sprintf "loading %s (%d,%d)\n",
821 $filename, length $data, scalar @{$av || []};#d# 1104 $decname, length $data, scalar @{$av || []};
1105
822 return ($data, $av); 1106 ($data, $av)
823} 1107}
1108
1109=head2 COMMAND CALLBACKS
1110
1111=over 4
1112
1113=cut
824 1114
825############################################################################# 1115#############################################################################
826# command handling &c 1116# command handling &c
827 1117
828=item cf::register_command $name => \&callback($ob,$args); 1118=item cf::register_command $name => \&callback($ob,$args);
… …
841 push @{ $COMMAND{$name} }, [$caller, $cb]; 1131 push @{ $COMMAND{$name} }, [$caller, $cb];
842} 1132}
843 1133
844=item cf::register_extcmd $name => \&callback($pl,$packet); 1134=item cf::register_extcmd $name => \&callback($pl,$packet);
845 1135
846Register a callbackf ro execution when the client sends an extcmd packet. 1136Register a callback for execution when the client sends an (synchronous)
1137extcmd packet. Ext commands will be processed in the order they are
1138received by the server, like other user commands. The first argument is
1139the logged-in player. Ext commands can only be processed after a player
1140has logged in successfully.
847 1141
848If the callback returns something, it is sent back as if reply was being 1142If the callback returns something, it is sent back as if reply was being
849called. 1143called.
850 1144
1145=item cf::register_exticmd $name => \&callback($ns,$packet);
1146
1147Register a callback for execution when the client sends an (asynchronous)
1148exticmd packet. Exti commands are processed by the server as soon as they
1149are received, i.e. out of order w.r.t. other commands. The first argument
1150is a client socket. Exti commands can be received anytime, even before
1151log-in.
1152
1153If the callback returns something, it is sent back as if reply was being
1154called.
1155
851=cut 1156=cut
852 1157
853sub register_extcmd { 1158sub register_extcmd {
854 my ($name, $cb) = @_; 1159 my ($name, $cb) = @_;
855 1160
856 $EXTCMD{$name} = $cb; 1161 $EXTCMD{$name} = $cb;
1162}
1163
1164sub register_exticmd {
1165 my ($name, $cb) = @_;
1166
1167 $EXTICMD{$name} = $cb;
857} 1168}
858 1169
859cf::player->attach ( 1170cf::player->attach (
860 on_command => sub { 1171 on_command => sub {
861 my ($pl, $name, $params) = @_; 1172 my ($pl, $name, $params) = @_;
… …
870 cf::override; 1181 cf::override;
871 }, 1182 },
872 on_extcmd => sub { 1183 on_extcmd => sub {
873 my ($pl, $buf) = @_; 1184 my ($pl, $buf) = @_;
874 1185
875 my $msg = eval { from_json $buf }; 1186 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
876 1187
877 if (ref $msg) { 1188 if (ref $msg) {
1189 my ($type, $reply, @payload) =
1190 "ARRAY" eq ref $msg
1191 ? @$msg
1192 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1193
1194 my @reply;
1195
878 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1196 if (my $cb = $EXTCMD{$type}) {
879 if (my %reply = $cb->($pl, $msg)) { 1197 @reply = $cb->($pl, @payload);
880 $pl->ext_reply ($msg->{msgid}, %reply);
881 }
882 } 1198 }
1199
1200 $pl->ext_reply ($reply, @reply)
1201 if $reply;
1202
883 } else { 1203 } else {
884 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1204 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
885 } 1205 }
886 1206
887 cf::override; 1207 cf::override;
888 }, 1208 },
889); 1209);
890 1210
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 { 1211sub load_extensions {
1212 cf::sync_job {
1213 my %todo;
1214
926 for my $ext (<$LIBDIR/*.ext>) { 1215 for my $path (<$LIBDIR/*.ext>) {
927 next unless -r $ext; 1216 next unless -r $path;
928 eval { 1217
929 load_extension $ext; 1218 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1219 my $base = $1;
1220 my $pkg = $1;
1221 $pkg =~ s/[^[:word:]]/_/g;
1222 $pkg = "ext::$pkg";
1223
1224 open my $fh, "<:utf8", $path
1225 or die "$path: $!";
1226
1227 my $source = do { local $/; <$fh> };
1228
1229 my %ext = (
1230 path => $path,
1231 base => $base,
1232 pkg => $pkg,
1233 );
1234
1235 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1236 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1237
1238 $ext{source} =
1239 "package $pkg; use strict; use utf8;\n"
1240 . "#line 1 \"$path\"\n{\n"
1241 . $source
1242 . "\n};\n1";
1243
1244 $todo{$base} = \%ext;
1245 }
1246
1247 my %done;
1248 while (%todo) {
1249 my $progress;
1250
1251 while (my ($k, $v) = each %todo) {
1252 for (split /,\s*/, $v->{meta}{depends}) {
1253 goto skip
1254 unless exists $done{$_};
1255 }
1256
1257 warn "... loading '$k' into '$v->{pkg}'\n";
1258
1259 unless (eval $v->{source}) {
1260 my $msg = $@ ? "$v->{path}: $@\n"
1261 : "$v->{base}: extension inactive.\n";
1262
1263 if (exists $v->{meta}{mandatory}) {
1264 warn $msg;
1265 warn "mandatory extension failed to load, exiting.\n";
1266 exit 1;
1267 }
1268
1269 warn $msg;
1270 }
1271
1272 $done{$k} = delete $todo{$k};
1273 push @EXTS, $v->{pkg};
1274 $progress = 1;
930 1 1275 }
931 } or warn "$ext not loaded: $@"; 1276
1277 skip:
1278 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1279 unless $progress;
1280 }
932 } 1281 };
933} 1282}
934 1283
935############################################################################# 1284#############################################################################
936 1285
1286=back
1287
937=head2 CORE EXTENSIONS 1288=head2 CORE EXTENSIONS
938 1289
939Functions and methods that extend core crossfire objects. 1290Functions and methods that extend core crossfire objects.
940 1291
941=cut 1292=cut
… …
946 1297
947=head3 cf::player 1298=head3 cf::player
948 1299
949=over 4 1300=over 4
950 1301
1302=item cf::player::num_playing
1303
1304Returns the official number of playing players, as per the Crossfire metaserver rules.
1305
1306=cut
1307
1308sub num_playing {
1309 scalar grep
1310 $_->ob->map
1311 && !$_->hidden
1312 && !$_->ob->flag (cf::FLAG_WIZ),
1313 cf::player::list
1314}
1315
951=item cf::player::find $login 1316=item cf::player::find $login
952 1317
953Returns the given player object, loading it if necessary (might block). 1318Returns the given player object, loading it if necessary (might block).
954 1319
955=cut 1320=cut
956 1321
957sub playerdir($) { 1322sub playerdir($) {
958 cf::localdir 1323 "$PLAYERDIR/"
959 . "/"
960 . cf::playerdir
961 . "/"
962 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1324 . (ref $_[0] ? $_[0]->ob->name : $_[0])
963} 1325}
964 1326
965sub path($) { 1327sub path($) {
966 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1328 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
967 1329
968 (playerdir $login) . "/$login.pl" 1330 (playerdir $login) . "/playerdata"
969} 1331}
970 1332
971sub find_active($) { 1333sub find_active($) {
972 $cf::PLAYER{$_[0]} 1334 $cf::PLAYER{$_[0]}
973 and $cf::PLAYER{$_[0]}->active 1335 and $cf::PLAYER{$_[0]}->active
… …
986 my $login = $_[0]; 1348 my $login = $_[0];
987 1349
988 my $guard = cf::lock_acquire "user_find:$login"; 1350 my $guard = cf::lock_acquire "user_find:$login";
989 1351
990 $cf::PLAYER{$_[0]} || do { 1352 $cf::PLAYER{$_[0]} || do {
991 my $pl = load_pl path $login 1353 # rename old playerfiles to new ones
1354 #TODO: remove when no longer required
1355 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1356 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1357 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1358 aio_unlink +(playerdir $login) . "/$login.pl";
1359
1360 my $f = new_from_file cf::object::thawer path $login
992 or return; 1361 or return;
1362
1363 my $pl = cf::player::load_pl $f
1364 or return;
1365 local $cf::PLAYER_LOADING{$login} = $pl;
1366 $f->resolve_delayed_derefs;
993 $cf::PLAYER{$login} = $pl 1367 $cf::PLAYER{$login} = $pl
994 } 1368 }
995 } 1369 }
996} 1370}
997 1371
… …
1007 1381
1008 aio_mkdir playerdir $pl, 0770; 1382 aio_mkdir playerdir $pl, 0770;
1009 $pl->{last_save} = $cf::RUNTIME; 1383 $pl->{last_save} = $cf::RUNTIME;
1010 1384
1011 $pl->save_pl ($path); 1385 $pl->save_pl ($path);
1012 Coro::cede; 1386 cf::cede_to_tick;
1013} 1387}
1014 1388
1015sub new($) { 1389sub new($) {
1016 my ($login) = @_; 1390 my ($login) = @_;
1017 1391
… …
1021 $self->{deny_save} = 1; 1395 $self->{deny_save} = 1;
1022 1396
1023 $cf::PLAYER{$login} = $self; 1397 $cf::PLAYER{$login} = $self;
1024 1398
1025 $self 1399 $self
1400}
1401
1402=item $player->send_msg ($channel, $msg, $color, [extra...])
1403
1404=cut
1405
1406sub send_msg {
1407 my $ns = shift->ns
1408 or return;
1409 $ns->send_msg (@_);
1026} 1410}
1027 1411
1028=item $pl->quit_character 1412=item $pl->quit_character
1029 1413
1030Nukes the player without looking back. If logged in, the connection will 1414Nukes the player without looking back. If logged in, the connection will
… …
1079while and may block, so not sync_job-capable, ever. 1463while and may block, so not sync_job-capable, ever.
1080 1464
1081=cut 1465=cut
1082 1466
1083sub list_logins { 1467sub list_logins {
1084 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1468 my $dirs = aio_readdir $PLAYERDIR
1085 or return []; 1469 or return [];
1086 1470
1087 my @logins; 1471 my @logins;
1088 1472
1089 for my $login (@$dirs) { 1473 for my $login (@$dirs) {
1474 my $path = path $login;
1475
1476 # a .pst is a dead give-away for a valid player
1477 unless (-e "$path.pst") {
1090 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1478 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1091 aio_read $fh, 0, 512, my $buf, 0 or next; 1479 aio_read $fh, 0, 512, my $buf, 0 or next;
1092 $buf !~ /^password -------------$/m or next; # official not-valid tag 1480 $buf !~ /^password -------------$/m or next; # official not-valid tag
1481 }
1093 1482
1094 utf8::decode $login; 1483 utf8::decode $login;
1095 push @logins, $login; 1484 push @logins, $login;
1096 } 1485 }
1097 1486
… …
1124 } 1513 }
1125 1514
1126 \@paths 1515 \@paths
1127} 1516}
1128 1517
1518=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1519
1520Expand crossfire pod fragments into protocol xml.
1521
1522=cut
1523
1524sub expand_cfpod {
1525 ((my $self), (local $_)) = @_;
1526
1527 # escape & and <
1528 s/&/&amp;/g;
1529 s/(?<![BIUGHT])</&lt;/g;
1530
1531 # this is buggy, it needs to properly take care of nested <'s
1532
1533 1 while
1534 # replace B<>, I<>, U<> etc.
1535 s/B<([^\>]*)>/<b>$1<\/b>/
1536 || s/I<([^\>]*)>/<i>$1<\/i>/
1537 || s/U<([^\>]*)>/<u>$1<\/u>/
1538 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1539 # replace G<male|female> tags
1540 || s{G<([^>|]*)\|([^>]*)>}{
1541 $self->gender ? $2 : $1
1542 }ge
1543 # replace H<hint text>
1544 || s{H<([^\>]*)>}
1545 {
1546 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1547 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1548 "")
1549 [$self->{hintmode}]
1550 }ge;
1551
1552 # create single paragraphs (very hackish)
1553 s/(?<=\S)\n(?=\w)/ /g;
1554
1555 # compress some whitespace
1556 s/\s+\n/\n/g; # ws line-ends
1557 s/\n\n+/\n/g; # double lines
1558 s/^\n+//; # beginning lines
1559 s/\n+$//; # ending lines
1560
1561 $_
1562}
1563
1564sub hintmode {
1565 $_[0]{hintmode} = $_[1] if @_ > 1;
1566 $_[0]{hintmode}
1567}
1568
1129=item $player->ext_reply ($msgid, $msgtype, %msg) 1569=item $player->ext_reply ($msgid, @msg)
1130 1570
1131Sends an ext reply to the player. 1571Sends an ext reply to the player.
1132 1572
1133=cut 1573=cut
1134 1574
1135sub ext_reply($$$%) { 1575sub ext_reply($$@) {
1136 my ($self, $id, %msg) = @_; 1576 my ($self, $id, @msg) = @_;
1137 1577
1138 $msg{msgid} = $id; 1578 $self->ns->ext_reply ($id, @msg)
1139
1140 $self->send ("ext " . cf::to_json \%msg);
1141} 1579}
1142 1580
1143package cf; 1581=item $player->ext_msg ($type, @msg)
1582
1583Sends an ext event to the client.
1584
1585=cut
1586
1587sub ext_msg($$@) {
1588 my ($self, $type, @msg) = @_;
1589
1590 $self->ns->ext_msg ($type, @msg);
1591}
1592
1593=head3 cf::region
1594
1595=over 4
1596
1597=cut
1598
1599package cf::region;
1600
1601=item cf::region::find_by_path $path
1602
1603Tries to decuce the likely region for a map knowing only its path.
1604
1605=cut
1606
1607sub find_by_path($) {
1608 my ($path) = @_;
1609
1610 my ($match, $specificity);
1611
1612 for my $region (list) {
1613 if ($region->{match} && $path =~ $region->{match}) {
1614 ($match, $specificity) = ($region, $region->specificity)
1615 if $region->specificity > $specificity;
1616 }
1617 }
1618
1619 $match
1620}
1144 1621
1145=back 1622=back
1146
1147 1623
1148=head3 cf::map 1624=head3 cf::map
1149 1625
1150=over 4 1626=over 4
1151 1627
… …
1206 my ($self, $merge) = @_; 1682 my ($self, $merge) = @_;
1207 1683
1208 # we have to keep some variables in memory intact 1684 # we have to keep some variables in memory intact
1209 local $self->{path}; 1685 local $self->{path};
1210 local $self->{load_path}; 1686 local $self->{load_path};
1211 local $self->{deny_save};
1212 local $self->{deny_reset};
1213 1687
1214 $self->SUPER::thawer_merge ($merge); 1688 $self->SUPER::thawer_merge ($merge);
1215} 1689}
1216 1690
1217sub normalise { 1691sub normalise {
… …
1264 $self->init; # pass $1 etc. 1738 $self->init; # pass $1 etc.
1265 return $self; 1739 return $self;
1266 } 1740 }
1267 } 1741 }
1268 1742
1269 Carp::carp "unable to resolve path '$path' (base '$base')."; 1743 Carp::cluck "unable to resolve path '$path' (base '$base').";
1270 () 1744 ()
1271} 1745}
1272 1746
1273sub init { 1747sub init {
1274 my ($self) = @_; 1748 my ($self) = @_;
… …
1289 1763
1290# the original (read-only) location 1764# the original (read-only) location
1291sub load_path { 1765sub load_path {
1292 my ($self) = @_; 1766 my ($self) = @_;
1293 1767
1294 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1768 "$MAPDIR/$self->{path}.map"
1295} 1769}
1296 1770
1297# the temporary/swap location 1771# the temporary/swap location
1298sub save_path { 1772sub save_path {
1299 my ($self) = @_; 1773 my ($self) = @_;
1300 1774
1301 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1775 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1302 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1776 "$TMPDIR/$path.map"
1303} 1777}
1304 1778
1305# the unique path, undef == no special unique path 1779# the unique path, undef == no special unique path
1306sub uniq_path { 1780sub uniq_path {
1307 my ($self) = @_; 1781 my ($self) = @_;
1308 1782
1309 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1783 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1310 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1784 "$UNIQUEDIR/$path"
1311} 1785}
1312 1786
1313# and all this just because we cannot iterate over 1787# and all this just because we cannot iterate over
1314# all maps in C++... 1788# all maps in C++...
1315sub change_all_map_light { 1789sub change_all_map_light {
… …
1317 1791
1318 $_->change_map_light ($change) 1792 $_->change_map_light ($change)
1319 for grep $_->outdoor, values %cf::MAP; 1793 for grep $_->outdoor, values %cf::MAP;
1320} 1794}
1321 1795
1796sub decay_objects {
1797 my ($self) = @_;
1798
1799 return if $self->{deny_reset};
1800
1801 $self->do_decay_objects;
1802}
1803
1322sub unlink_save { 1804sub unlink_save {
1323 my ($self) = @_; 1805 my ($self) = @_;
1324 1806
1325 utf8::encode (my $save = $self->save_path); 1807 utf8::encode (my $save = $self->save_path);
1326 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1808 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1329 1811
1330sub load_header_from($) { 1812sub load_header_from($) {
1331 my ($self, $path) = @_; 1813 my ($self, $path) = @_;
1332 1814
1333 utf8::encode $path; 1815 utf8::encode $path;
1334 #aio_open $path, O_RDONLY, 0 1816 my $f = new_from_file cf::object::thawer $path
1335 # or return;
1336
1337 $self->_load_header ($path)
1338 or return; 1817 or return;
1818
1819 $self->_load_header ($f)
1820 or return;
1821
1822 local $MAP_LOADING{$self->{path}} = $self;
1823 $f->resolve_delayed_derefs;
1339 1824
1340 $self->{load_path} = $path; 1825 $self->{load_path} = $path;
1341 1826
1342 1 1827 1
1343} 1828}
… …
1382 $self->load_header_orig 1867 $self->load_header_orig
1383 or return; 1868 or return;
1384 $self->prepare_orig; 1869 $self->prepare_orig;
1385 } 1870 }
1386 1871
1872 $self->{deny_reset} = 1
1873 if $self->no_reset;
1874
1875 $self->default_region (cf::region::find_by_path $self->{path})
1876 unless $self->default_region;
1877
1387 1 1878 1
1388} 1879}
1389 1880
1390sub find; 1881sub find;
1391sub find { 1882sub find {
1392 my ($path, $origin) = @_; 1883 my ($path, $origin) = @_;
1393 1884
1394 $path = normalise $path, $origin && $origin->path; 1885 $path = normalise $path, $origin && $origin->path;
1395 1886
1887 cf::lock_wait "map_data:$path";#d#remove
1396 cf::lock_wait "map_find:$path"; 1888 cf::lock_wait "map_find:$path";
1397 1889
1398 $cf::MAP{$path} || do { 1890 $cf::MAP{$path} || do {
1399 my $guard = cf::lock_acquire "map_find:$path"; 1891 my $guard1 = cf::lock_acquire "map_find:$path";
1892 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1893
1400 my $map = new_from_path cf::map $path 1894 my $map = new_from_path cf::map $path
1401 or return; 1895 or return;
1402 1896
1403 $map->{last_save} = $cf::RUNTIME; 1897 $map->{last_save} = $cf::RUNTIME;
1404 1898
1405 $map->load_header 1899 $map->load_header
1406 or return; 1900 or return;
1407 1901
1408 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1902 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1409 # doing this can freeze the server in a sync job, obviously 1903 # doing this can freeze the server in a sync job, obviously
1410 #$cf::WAIT_FOR_TICK->wait; 1904 #$cf::WAIT_FOR_TICK->wait;
1905 undef $guard1;
1906 undef $guard2;
1411 $map->reset; 1907 $map->reset;
1412 undef $guard;
1413 return find $path; 1908 return find $path;
1414 } 1909 }
1415 1910
1416 $cf::MAP{$path} = $map 1911 $cf::MAP{$path} = $map
1417 } 1912 }
… …
1424 my ($self) = @_; 1919 my ($self) = @_;
1425 1920
1426 local $self->{deny_reset} = 1; # loading can take a long time 1921 local $self->{deny_reset} = 1; # loading can take a long time
1427 1922
1428 my $path = $self->{path}; 1923 my $path = $self->{path};
1924
1925 {
1429 my $guard = cf::lock_acquire "map_load:$path"; 1926 my $guard = cf::lock_acquire "map_data:$path";
1430 1927
1928 return unless $self->valid;
1431 return if $self->in_memory != cf::MAP_SWAPPED; 1929 return unless $self->in_memory == cf::MAP_SWAPPED;
1432 1930
1433 $self->in_memory (cf::MAP_LOADING); 1931 $self->in_memory (cf::MAP_LOADING);
1434 1932
1435 $self->alloc; 1933 $self->alloc;
1436 1934
1437 $self->pre_load; 1935 $self->pre_load;
1936 cf::cede_to_tick;
1438 1937
1439 $self->_load_objects ($self->{load_path}, 1) 1938 my $f = new_from_file cf::object::thawer $self->{load_path};
1939 $f->skip_block;
1940 $self->_load_objects ($f)
1440 or return; 1941 or return;
1441 1942
1442 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1943 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1443 if delete $self->{load_original}; 1944 if delete $self->{load_original};
1444 1945
1445 if (my $uniq = $self->uniq_path) { 1946 if (my $uniq = $self->uniq_path) {
1446 utf8::encode $uniq; 1947 utf8::encode $uniq;
1447 if (aio_open $uniq, O_RDONLY, 0) { 1948 unless (aio_stat $uniq) {
1949 if (my $f = new_from_file cf::object::thawer $uniq) {
1448 $self->clear_unique_items; 1950 $self->clear_unique_items;
1449 $self->_load_objects ($uniq, 0); 1951 $self->_load_objects ($f);
1952 $f->resolve_delayed_derefs;
1953 }
1450 } 1954 }
1451 } 1955 }
1452 1956
1453 Coro::cede; 1957 $f->resolve_delayed_derefs;
1454 1958
1959 cf::cede_to_tick;
1455 # now do the right thing for maps 1960 # now do the right thing for maps
1456 $self->link_multipart_objects; 1961 $self->link_multipart_objects;
1457
1458 unless ($self->{deny_activate}) {
1459 $self->decay_objects;
1460 $self->fix_auto_apply;
1461 $self->update_buttons;
1462 Coro::cede;
1463 $self->set_darkness_map;
1464 $self->difficulty ($self->estimate_difficulty) 1962 $self->difficulty ($self->estimate_difficulty)
1465 unless $self->difficulty; 1963 unless $self->difficulty;
1466 Coro::cede; 1964 cf::cede_to_tick;
1965
1966 unless ($self->{deny_activate}) {
1967 $self->decay_objects;
1968 $self->fix_auto_apply;
1969 $self->update_buttons;
1970 cf::cede_to_tick;
1971 $self->set_darkness_map;
1972 cf::cede_to_tick;
1467 $self->activate; 1973 $self->activate;
1974 }
1975
1976 $self->{last_save} = $cf::RUNTIME;
1977 $self->last_access ($cf::RUNTIME);
1978
1979 $self->in_memory (cf::MAP_IN_MEMORY);
1468 } 1980 }
1469 1981
1470 $self->post_load; 1982 $self->post_load;
1471
1472 $self->in_memory (cf::MAP_IN_MEMORY);
1473} 1983}
1474 1984
1475sub customise_for { 1985sub customise_for {
1476 my ($self, $ob) = @_; 1986 my ($self, $ob) = @_;
1477 1987
1478 return find "~" . $ob->name . "/" . $self->{path} 1988 return find "~" . $ob->name . "/" . $self->{path}
1479 if $self->per_player; 1989 if $self->per_player;
1480 1990
1991# return find "?party/" . $ob->name . "/" . $self->{path}
1992# if $self->per_party;
1993
1481 $self 1994 $self
1482} 1995}
1483 1996
1484# find and load all maps in the 3x3 area around a map 1997# find and load all maps in the 3x3 area around a map
1485sub load_diag { 1998sub load_neighbours {
1486 my ($map) = @_; 1999 my ($map) = @_;
1487 2000
1488 my @diag; # diagonal neighbours 2001 my @neigh; # diagonal neighbours
1489 2002
1490 for (0 .. 3) { 2003 for (0 .. 3) {
1491 my $neigh = $map->tile_path ($_) 2004 my $neigh = $map->tile_path ($_)
1492 or next; 2005 or next;
1493 $neigh = find $neigh, $map 2006 $neigh = find $neigh, $map
1494 or next; 2007 or next;
1495 $neigh->load; 2008 $neigh->load;
1496 2009
2010 push @neigh,
1497 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2011 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1498 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2012 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1499 } 2013 }
1500 2014
1501 for (@diag) { 2015 for (grep defined $_->[0], @neigh) {
2016 my ($path, $origin) = @$_;
1502 my $neigh = find @$_ 2017 my $neigh = find $path, $origin
1503 or next; 2018 or next;
1504 $neigh->load; 2019 $neigh->load;
1505 } 2020 }
1506} 2021}
1507 2022
… …
1512} 2027}
1513 2028
1514sub do_load_sync { 2029sub do_load_sync {
1515 my ($map) = @_; 2030 my ($map) = @_;
1516 2031
2032 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2033 if $Coro::current == $Coro::main;
2034
1517 cf::sync_job { $map->load }; 2035 cf::sync_job { $map->load };
1518} 2036}
1519 2037
1520our %MAP_PREFETCH; 2038our %MAP_PREFETCH;
1521our $MAP_PREFETCHER = undef; 2039our $MAP_PREFETCHER = undef;
1522 2040
1523sub find_async { 2041sub find_async {
1524 my ($path, $origin) = @_; 2042 my ($path, $origin, $load) = @_;
1525 2043
1526 $path = normalise $path, $origin && $origin->{path}; 2044 $path = normalise $path, $origin && $origin->{path};
1527 2045
1528 if (my $map = $cf::MAP{$path}) { 2046 if (my $map = $cf::MAP{$path}) {
1529 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2047 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1530 } 2048 }
1531 2049
1532 undef $MAP_PREFETCH{$path}; 2050 $MAP_PREFETCH{$path} |= $load;
2051
1533 $MAP_PREFETCHER ||= cf::async { 2052 $MAP_PREFETCHER ||= cf::async {
2053 $Coro::current->{desc} = "map prefetcher";
2054
1534 while (%MAP_PREFETCH) { 2055 while (%MAP_PREFETCH) {
1535 for my $path (keys %MAP_PREFETCH) { 2056 while (my ($k, $v) = each %MAP_PREFETCH) {
1536 my $map = find $path 2057 if (my $map = find $k) {
1537 or next;
1538 $map->load; 2058 $map->load if $v;
2059 }
1539 2060
1540 delete $MAP_PREFETCH{$path}; 2061 delete $MAP_PREFETCH{$k};
1541 } 2062 }
1542 } 2063 }
1543 undef $MAP_PREFETCHER; 2064 undef $MAP_PREFETCHER;
1544 }; 2065 };
1545 $MAP_PREFETCHER->prio (6); 2066 $MAP_PREFETCHER->prio (6);
… …
1548} 2069}
1549 2070
1550sub save { 2071sub save {
1551 my ($self) = @_; 2072 my ($self) = @_;
1552 2073
1553 my $lock = cf::lock_acquire "map_data:" . $self->path; 2074 my $lock = cf::lock_acquire "map_data:$self->{path}";
1554 2075
1555 $self->{last_save} = $cf::RUNTIME; 2076 $self->{last_save} = $cf::RUNTIME;
1556 2077
1557 return unless $self->dirty; 2078 return unless $self->dirty;
1558 2079
… …
1564 return if $self->{deny_save}; 2085 return if $self->{deny_save};
1565 2086
1566 local $self->{last_access} = $self->last_access;#d# 2087 local $self->{last_access} = $self->last_access;#d#
1567 2088
1568 cf::async { 2089 cf::async {
2090 $Coro::current->{desc} = "map player save";
1569 $_->contr->save for $self->players; 2091 $_->contr->save for $self->players;
1570 }; 2092 };
1571 2093
1572 if ($uniq) { 2094 if ($uniq) {
1573 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2095 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1581 my ($self) = @_; 2103 my ($self) = @_;
1582 2104
1583 # save first because save cedes 2105 # save first because save cedes
1584 $self->save; 2106 $self->save;
1585 2107
1586 my $lock = cf::lock_acquire "map_data:" . $self->path; 2108 my $lock = cf::lock_acquire "map_data:$self->{path}";
1587 2109
1588 return if $self->players; 2110 return if $self->players;
1589 return if $self->in_memory != cf::MAP_IN_MEMORY; 2111 return if $self->in_memory != cf::MAP_IN_MEMORY;
1590 return if $self->{deny_save}; 2112 return if $self->{deny_save};
1591 2113
2114 $self->in_memory (cf::MAP_SWAPPED);
2115
2116 $self->deactivate;
2117 $_->clear_links_to ($self) for values %cf::MAP;
1592 $self->clear; 2118 $self->clear;
1593 $self->in_memory (cf::MAP_SWAPPED);
1594} 2119}
1595 2120
1596sub reset_at { 2121sub reset_at {
1597 my ($self) = @_; 2122 my ($self) = @_;
1598 2123
1599 # TODO: safety, remove and allow resettable per-player maps 2124 # TODO: safety, remove and allow resettable per-player maps
1600 return 1e99 if $self->isa ("ext::map_per_player");#d#
1601 return 1e99 if $self->{deny_reset}; 2125 return 1e99 if $self->{deny_reset};
1602 2126
1603 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2127 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1604 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2128 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1605 2129
… …
1616 my ($self) = @_; 2140 my ($self) = @_;
1617 2141
1618 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2142 my $lock = cf::lock_acquire "map_data:$self->{path}";
1619 2143
1620 return if $self->players; 2144 return if $self->players;
1621 return if $self->isa ("ext::map_per_player");#d#
1622 2145
1623 warn "resetting map ", $self->path;#d# 2146 warn "resetting map ", $self->path;
1624 2147
1625 $self->in_memory (cf::MAP_SWAPPED); 2148 $self->in_memory (cf::MAP_SWAPPED);
1626 2149
1627 # need to save uniques path 2150 # need to save uniques path
1628 unless ($self->{deny_save}) { 2151 unless ($self->{deny_save}) {
… …
1632 if $uniq; 2155 if $uniq;
1633 } 2156 }
1634 2157
1635 delete $cf::MAP{$self->path}; 2158 delete $cf::MAP{$self->path};
1636 2159
2160 $self->deactivate;
2161 $_->clear_links_to ($self) for values %cf::MAP;
1637 $self->clear; 2162 $self->clear;
1638
1639 $_->clear_links_to ($self) for values %cf::MAP;
1640 2163
1641 $self->unlink_save; 2164 $self->unlink_save;
1642 $self->destroy; 2165 $self->destroy;
1643} 2166}
1644 2167
1645my $nuke_counter = "aaaa"; 2168my $nuke_counter = "aaaa";
1646 2169
1647sub nuke { 2170sub nuke {
1648 my ($self) = @_; 2171 my ($self) = @_;
1649 2172
2173 {
2174 my $lock = cf::lock_acquire "map_data:$self->{path}";
2175
1650 delete $cf::MAP{$self->path}; 2176 delete $cf::MAP{$self->path};
1651 2177
1652 $self->unlink_save; 2178 $self->unlink_save;
1653 2179
1654 bless $self, "cf::map"; 2180 bless $self, "cf::map";
1655 delete $self->{deny_reset}; 2181 delete $self->{deny_reset};
1656 $self->{deny_save} = 1; 2182 $self->{deny_save} = 1;
1657 $self->reset_timeout (1); 2183 $self->reset_timeout (1);
1658 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2184 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1659 2185
1660 $cf::MAP{$self->path} = $self; 2186 $cf::MAP{$self->path} = $self;
2187 }
1661 2188
1662 $self->reset; # polite request, might not happen 2189 $self->reset; # polite request, might not happen
2190}
2191
2192=item $maps = cf::map::tmp_maps
2193
2194Returns an arrayref with all map paths of currently instantiated and saved
2195maps. May block.
2196
2197=cut
2198
2199sub tmp_maps() {
2200 [
2201 map {
2202 utf8::decode $_;
2203 /\.map$/
2204 ? normalise $_
2205 : ()
2206 } @{ aio_readdir $TMPDIR or [] }
2207 ]
2208}
2209
2210=item $maps = cf::map::random_maps
2211
2212Returns an arrayref with all map paths of currently instantiated and saved
2213random maps. May block.
2214
2215=cut
2216
2217sub random_maps() {
2218 [
2219 map {
2220 utf8::decode $_;
2221 /\.map$/
2222 ? normalise "?random/$_"
2223 : ()
2224 } @{ aio_readdir $RANDOMDIR or [] }
2225 ]
1663} 2226}
1664 2227
1665=item cf::map::unique_maps 2228=item cf::map::unique_maps
1666 2229
1667Returns an arrayref of paths of all shared maps that have 2230Returns an arrayref of paths of all shared maps that have
1668instantiated unique items. May block. 2231instantiated unique items. May block.
1669 2232
1670=cut 2233=cut
1671 2234
1672sub unique_maps() { 2235sub unique_maps() {
1673 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2236 [
1674 or return; 2237 map {
1675
1676 my @paths;
1677
1678 for (@$files) {
1679 utf8::decode $_; 2238 utf8::decode $_;
1680 next if /\.pst$/; 2239 /\.map$/
1681 next unless /^$PATH_SEP/o; 2240 ? normalise $_
1682 2241 : ()
1683 push @paths, cf::map::normalise $_; 2242 } @{ aio_readdir $UNIQUEDIR or [] }
1684 } 2243 ]
1685
1686 \@paths
1687} 2244}
1688 2245
1689package cf; 2246package cf;
1690 2247
1691=back 2248=back
… …
1709 map { $_, inv_recursive_ $_->inv } @_ 2266 map { $_, inv_recursive_ $_->inv } @_
1710} 2267}
1711 2268
1712sub inv_recursive { 2269sub inv_recursive {
1713 inv_recursive_ inv $_[0] 2270 inv_recursive_ inv $_[0]
2271}
2272
2273=item $ref = $ob->ref
2274
2275creates and returns a persistent reference to an objetc that can be stored as a string.
2276
2277=item $ob = cf::object::deref ($refstring)
2278
2279returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2280even if the object actually exists. May block.
2281
2282=cut
2283
2284sub deref {
2285 my ($ref) = @_;
2286
2287 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2288 my ($uuid, $name) = ($1, $2);
2289 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2290 or return;
2291 $pl->ob->uuid eq $uuid
2292 or return;
2293
2294 $pl->ob
2295 } else {
2296 warn "$ref: cannot resolve object reference\n";
2297 undef
2298 }
1714} 2299}
1715 2300
1716package cf; 2301package cf;
1717 2302
1718=back 2303=back
… …
1737 2322
1738 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2323 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1739 2324
1740 if ($self->{record_replies}) { 2325 if ($self->{record_replies}) {
1741 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2326 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2327
1742 } else { 2328 } else {
2329 my $pl = $self->contr;
2330
2331 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2332 my $dialog = $pl->{npc_dialog};
2333 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2334
2335 } else {
1743 $msg = $npc->name . " says: $msg" if $npc; 2336 $msg = $npc->name . " says: $msg" if $npc;
1744 $self->message ($msg, $flags); 2337 $self->message ($msg, $flags);
2338 }
1745 } 2339 }
2340}
2341
2342=item $object->send_msg ($channel, $msg, $color, [extra...])
2343
2344=cut
2345
2346sub cf::object::send_msg {
2347 my $pl = shift->contr
2348 or return;
2349 $pl->send_msg (@_);
1746} 2350}
1747 2351
1748=item $player_object->may ("access") 2352=item $player_object->may ("access")
1749 2353
1750Returns wether the given player is authorized to access resource "access" 2354Returns wether the given player is authorized to access resource "access"
… …
1797 $self->deactivate_recursive; 2401 $self->deactivate_recursive;
1798 2402
1799 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2403 return if UNIVERSAL::isa $self->map, "ext::map_link";
1800 2404
1801 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2405 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1802 if $self->map; 2406 if $self->map && $self->map->{path} ne "{link}";
1803 2407
1804 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2408 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1805} 2409}
1806 2410
1807sub cf::object::player::leave_link { 2411sub cf::object::player::leave_link {
1808 my ($self, $map, $x, $y) = @_; 2412 my ($self, $map, $x, $y) = @_;
2413
2414 return unless $self->contr->active;
1809 2415
1810 my $link_pos = delete $self->{_link_pos}; 2416 my $link_pos = delete $self->{_link_pos};
1811 2417
1812 unless ($map) { 2418 unless ($map) {
1813 # restore original map position 2419 # restore original map position
… …
1827 # use -1 or undef as default coordinates, not 0, 0 2433 # use -1 or undef as default coordinates, not 0, 0
1828 ($x, $y) = ($map->enter_x, $map->enter_y) 2434 ($x, $y) = ($map->enter_x, $map->enter_y)
1829 if $x <=0 && $y <= 0; 2435 if $x <=0 && $y <= 0;
1830 2436
1831 $map->load; 2437 $map->load;
1832 $map->load_diag; 2438 $map->load_neighbours;
1833 2439
1834 return unless $self->contr->active; 2440 return unless $self->contr->active;
1835 $self->activate_recursive; 2441 $self->activate_recursive;
1836 2442
1837 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2443 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1838 $self->enter_map ($map, $x, $y); 2444 $self->enter_map ($map, $x, $y);
1839} 2445}
1840 2446
1841cf::player->attach ( 2447=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1842 on_logout => sub {
1843 my ($pl) = @_;
1844 2448
1845 # abort map switching before logout 2449Moves the player to the given map-path and coordinates by first freezing
1846 if ($pl->ob->{_link_pos}) { 2450her, loading and preparing them map, calling the provided $check callback
1847 cf::sync_job { 2451that has to return the map if sucecssful, and then unfreezes the player on
1848 $pl->ob->leave_link 2452the new (success) or old (failed) map position. In either case, $done will
1849 }; 2453be called at the end of this process.
1850 }
1851 },
1852 on_login => sub {
1853 my ($pl) = @_;
1854 2454
1855 # try to abort aborted map switching on player login :)
1856 # should happen only on crashes
1857 if ($pl->ob->{_link_pos}) {
1858 $pl->ob->enter_link;
1859 (async {
1860 $pl->ob->reply (undef,
1861 "There was an internal problem at your last logout, "
1862 . "the server will try to bring you to your intended destination in a second.",
1863 cf::NDI_RED);
1864 # we need this sleep as the login has a concurrent enter_exit running
1865 # and this sleep increases chances of the player not ending up in scorn
1866 Coro::Timer::sleep 1;
1867 $pl->ob->leave_link;
1868 })->prio (2);
1869 }
1870 },
1871);
1872
1873=item $player_object->goto ($path, $x, $y)
1874
1875=cut 2455=cut
2456
2457our $GOTOGEN;
1876 2458
1877sub cf::object::player::goto { 2459sub cf::object::player::goto {
1878 my ($self, $path, $x, $y) = @_; 2460 my ($self, $path, $x, $y, $check, $done) = @_;
2461
2462 # do generation counting so two concurrent goto's will be executed in-order
2463 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1879 2464
1880 $self->enter_link; 2465 $self->enter_link;
1881 2466
1882 (async { 2467 (async {
2468 $Coro::current->{desc} = "player::goto $path $x $y";
2469
2470 # *tag paths override both path and x|y
2471 if ($path =~ /^\*(.*)$/) {
2472 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2473 my $ob = $obs[rand @obs];
2474
2475 # see if we actually can go there
2476 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2477 $ob = $obs[rand @obs];
2478 } else {
2479 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2480 }
2481 # else put us there anyways for now #d#
2482
2483 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2484 } else {
2485 ($path, $x, $y) = (undef, undef, undef);
2486 }
2487 }
2488
1883 my $map = eval { 2489 my $map = eval {
1884 my $map = cf::map::find $path; 2490 my $map = defined $path ? cf::map::find $path : undef;
2491
2492 if ($map) {
1885 $map = $map->customise_for ($self) if $map; 2493 $map = $map->customise_for ($self);
2494 $map = $check->($map) if $check && $map;
2495 } else {
2496 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2497 }
2498
1886 $map 2499 $map
2500 };
2501
2502 if ($@) {
2503 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2504 LOG llevError | logBacktrace, Carp::longmess $@;
1887 } or 2505 }
1888 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1889 2506
2507 if ($gen == $self->{_goto_generation}) {
2508 delete $self->{_goto_generation};
1890 $self->leave_link ($map, $x, $y); 2509 $self->leave_link ($map, $x, $y);
2510 }
2511
2512 $done->() if $done;
1891 })->prio (1); 2513 })->prio (1);
1892} 2514}
1893 2515
1894=item $player_object->enter_exit ($exit_object) 2516=item $player_object->enter_exit ($exit_object)
1895 2517
… …
1934 2556
1935 $rmp->{random_seed} ||= $exit->random_seed; 2557 $rmp->{random_seed} ||= $exit->random_seed;
1936 2558
1937 my $data = cf::to_json $rmp; 2559 my $data = cf::to_json $rmp;
1938 my $md5 = Digest::MD5::md5_hex $data; 2560 my $md5 = Digest::MD5::md5_hex $data;
1939 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2561 my $meta = "$RANDOMDIR/$md5.meta";
1940 2562
1941 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2563 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1942 aio_write $fh, 0, (length $data), $data, 0; 2564 aio_write $fh, 0, (length $data), $data, 0;
1943 undef $fh; 2565 undef $fh;
1944 aio_rename "$meta~", $meta; 2566 aio_rename "$meta~", $meta;
… …
1953 2575
1954 return unless $self->type == cf::PLAYER; 2576 return unless $self->type == cf::PLAYER;
1955 2577
1956 if ($exit->slaying eq "/!") { 2578 if ($exit->slaying eq "/!") {
1957 #TODO: this should de-fi-ni-te-ly not be a sync-job 2579 #TODO: this should de-fi-ni-te-ly not be a sync-job
2580 # the problem is that $exit might not survive long enough
2581 # so it needs to be done right now, right here
1958 cf::sync_job { prepare_random_map $exit }; 2582 cf::sync_job { prepare_random_map $exit };
1959 } 2583 }
1960 2584
1961 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2585 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1962 my $hp = $exit->stats->hp; 2586 my $hp = $exit->stats->hp;
1963 my $sp = $exit->stats->sp; 2587 my $sp = $exit->stats->sp;
1964 2588
1965 $self->enter_link; 2589 $self->enter_link;
1966 2590
2591 # if exit is damned, update players death & WoR home-position
2592 $self->contr->savebed ($slaying, $hp, $sp)
2593 if $exit->flag (FLAG_DAMNED);
2594
1967 (async { 2595 (async {
2596 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2597
1968 $self->deactivate_recursive; # just to be sure 2598 $self->deactivate_recursive; # just to be sure
1969 unless (eval { 2599 unless (eval {
1970 $self->goto ($slaying, $hp, $sp); 2600 $self->goto ($slaying, $hp, $sp);
1971 2601
1972 1; 2602 1;
1973 }) { 2603 }) {
1974 $self->message ("Something went wrong deep within the crossfire server. " 2604 $self->message ("Something went wrong deep within the crossfire server. "
1975 . "I'll try to bring you back to the map you were before. " 2605 . "I'll try to bring you back to the map you were before. "
1976 . "Please report this to the dungeon master!", 2606 . "Please report this to the dungeon master!",
1977 cf::NDI_UNIQUE | cf::NDI_RED); 2607 cf::NDI_UNIQUE | cf::NDI_RED);
1978 2608
1979 warn "ERROR in enter_exit: $@"; 2609 warn "ERROR in enter_exit: $@";
1980 $self->leave_link; 2610 $self->leave_link;
1981 } 2611 }
1982 })->prio (1); 2612 })->prio (1);
… …
1995 2625
1996sub cf::client::send_drawinfo { 2626sub cf::client::send_drawinfo {
1997 my ($self, $text, $flags) = @_; 2627 my ($self, $text, $flags) = @_;
1998 2628
1999 utf8::encode $text; 2629 utf8::encode $text;
2000 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2630 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2001} 2631}
2002 2632
2633=item $client->send_msg ($channel, $msg, $color, [extra...])
2634
2635Send a drawinfo or msg packet to the client, formatting the msg for the
2636client if neccessary. C<$type> should be a string identifying the type of
2637the message, with C<log> being the default. If C<$color> is negative, suppress
2638the message unless the client supports the msg packet.
2639
2640=cut
2641
2642our %CHANNEL = (
2643 "c/identify" => {
2644 id => "infobox",
2645 title => "Identify",
2646 reply => undef,
2647 tooltip => "Items recently identified",
2648 },
2649 "c/examine" => {
2650 id => "infobox",
2651 title => "Examine",
2652 reply => undef,
2653 tooltip => "Signs and other items you examined",
2654 },
2655 "c/lookat" => {
2656 id => "infobox",
2657 title => "Look",
2658 reply => undef,
2659 tooltip => "What you saw there",
2660 },
2661);
2662
2663sub cf::client::send_msg {
2664 my ($self, $channel, $msg, $color, @extra) = @_;
2665
2666 $msg = $self->pl->expand_cfpod ($msg);
2667
2668 $color &= cf::NDI_CLIENT_MASK; # just in case...
2669
2670 # check predefined channels, for the benefit of C
2671 if ($CHANNEL{$channel}) {
2672 $channel = $CHANNEL{$channel};
2673
2674 $self->ext_msg (channel_info => $channel)
2675 if $self->can_msg;
2676
2677 $channel = $channel->{id};
2678
2679 } elsif (ref $channel) {
2680 # send meta info to client, if not yet sent
2681 unless (exists $self->{channel}{$channel->{id}}) {
2682 $self->{channel}{$channel->{id}} = $channel;
2683 $self->ext_msg (channel_info => $channel)
2684 if $self->can_msg;
2685 }
2686
2687 $channel = $channel->{id};
2688 }
2689
2690 return unless @extra || length $msg;
2691
2692 if ($self->can_msg) {
2693 # default colour, mask it out
2694 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2695 if $color & cf::NDI_DEF;
2696
2697 $self->send_packet ("msg " . $self->{json_coder}->encode (
2698 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2699 } else {
2700 if ($color >= 0) {
2701 # replace some tags by gcfclient-compatible ones
2702 for ($msg) {
2703 1 while
2704 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2705 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2706 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2707 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2708 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2709 }
2710
2711 $color &= cf::NDI_COLOR_MASK;
2712
2713 utf8::encode $msg;
2714
2715 if (0 && $msg =~ /\[/) {
2716 # COMMAND/INFO
2717 $self->send_packet ("drawextinfo $color 10 8 $msg")
2718 } else {
2719 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2720 $self->send_packet ("drawinfo $color $msg")
2721 }
2722 }
2723 }
2724}
2725
2726=item $client->ext_msg ($type, @msg)
2727
2728Sends an ext event to the client.
2729
2730=cut
2731
2732sub cf::client::ext_msg($$@) {
2733 my ($self, $type, @msg) = @_;
2734
2735 if ($self->extcmd == 2) {
2736 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2737 } elsif ($self->extcmd == 1) { # TODO: remove
2738 push @msg, msgtype => "event_$type";
2739 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2740 }
2741}
2742
2743=item $client->ext_reply ($msgid, @msg)
2744
2745Sends an ext reply to the client.
2746
2747=cut
2748
2749sub cf::client::ext_reply($$@) {
2750 my ($self, $id, @msg) = @_;
2751
2752 if ($self->extcmd == 2) {
2753 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2754 } elsif ($self->extcmd == 1) {
2755 #TODO: version 1, remove
2756 unshift @msg, msgtype => "reply", msgid => $id;
2757 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2758 }
2759}
2003 2760
2004=item $success = $client->query ($flags, "text", \&cb) 2761=item $success = $client->query ($flags, "text", \&cb)
2005 2762
2006Queues a query to the client, calling the given callback with 2763Queues a query to the client, calling the given callback with
2007the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2764the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2008C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2765C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2009 2766
2010Queries can fail, so check the return code. Or don't, as queries will become 2767Queries can fail, so check the return code. Or don't, as queries will
2011reliable at some point in the future. 2768become reliable at some point in the future.
2012 2769
2013=cut 2770=cut
2014 2771
2015sub cf::client::query { 2772sub cf::client::query {
2016 my ($self, $flags, $text, $cb) = @_; 2773 my ($self, $flags, $text, $cb) = @_;
… …
2024 utf8::encode $text; 2781 utf8::encode $text;
2025 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2782 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2026 2783
2027 $self->send_packet ($self->{query_queue}[0][0]) 2784 $self->send_packet ($self->{query_queue}[0][0])
2028 if @{ $self->{query_queue} } == 1; 2785 if @{ $self->{query_queue} } == 1;
2786
2787 1
2029} 2788}
2030 2789
2031cf::client->attach ( 2790cf::client->attach (
2791 on_connect => sub {
2792 my ($ns) = @_;
2793
2794 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2795 },
2032 on_reply => sub { 2796 on_reply => sub {
2033 my ($ns, $msg) = @_; 2797 my ($ns, $msg) = @_;
2034 2798
2035 # this weird shuffling is so that direct followup queries 2799 # this weird shuffling is so that direct followup queries
2036 # get handled first 2800 # get handled first
… …
2048 } else { 2812 } else {
2049 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2813 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2050 } 2814 }
2051 } 2815 }
2052 }, 2816 },
2817 on_exticmd => sub {
2818 my ($ns, $buf) = @_;
2819
2820 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2821
2822 if (ref $msg) {
2823 my ($type, $reply, @payload) =
2824 "ARRAY" eq ref $msg
2825 ? @$msg
2826 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2827
2828 my @reply;
2829
2830 if (my $cb = $EXTICMD{$type}) {
2831 @reply = $cb->($ns, @payload);
2832 }
2833
2834 $ns->ext_reply ($reply, @reply)
2835 if $reply;
2836
2837 } else {
2838 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2839 }
2840
2841 cf::override;
2842 },
2053); 2843);
2054 2844
2055=item $client->async (\&cb) 2845=item $client->async (\&cb)
2056 2846
2057Create a new coroutine, running the specified callback. The coroutine will 2847Create a new coroutine, running the specified callback. The coroutine will
… …
2098our $safe = new Safe "safe"; 2888our $safe = new Safe "safe";
2099our $safe_hole = new Safe::Hole; 2889our $safe_hole = new Safe::Hole;
2100 2890
2101$SIG{FPE} = 'IGNORE'; 2891$SIG{FPE} = 'IGNORE';
2102 2892
2103$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2893$safe->permit_only (Opcode::opset qw(
2894 :base_core :base_mem :base_orig :base_math
2895 grepstart grepwhile mapstart mapwhile
2896 sort time
2897));
2104 2898
2105# here we export the classes and methods available to script code 2899# here we export the classes and methods available to script code
2106 2900
2107=pod 2901=pod
2108 2902
2109The following fucntions and emthods are available within a safe environment: 2903The following functions and methods are available within a safe environment:
2110 2904
2111 cf::object contr pay_amount pay_player map 2905 cf::object
2906 contr pay_amount pay_player map x y force_find force_add destroy
2907 insert remove name archname title slaying race decrease_ob_nr
2908
2112 cf::object::player player 2909 cf::object::player
2113 cf::player peaceful 2910 player
2114 cf::map trigger 2911
2912 cf::player
2913 peaceful
2914
2915 cf::map
2916 trigger
2115 2917
2116=cut 2918=cut
2117 2919
2118for ( 2920for (
2119 ["cf::object" => qw(contr pay_amount pay_player map)], 2921 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2922 insert remove inv name archname title slaying race
2923 decrease_ob_nr destroy)],
2120 ["cf::object::player" => qw(player)], 2924 ["cf::object::player" => qw(player)],
2121 ["cf::player" => qw(peaceful)], 2925 ["cf::player" => qw(peaceful)],
2122 ["cf::map" => qw(trigger)], 2926 ["cf::map" => qw(trigger)],
2123) { 2927) {
2124 no strict 'refs'; 2928 no strict 'refs';
… …
2195=back 2999=back
2196 3000
2197=cut 3001=cut
2198 3002
2199############################################################################# 3003#############################################################################
2200
2201=head2 EXTENSION DATABASE SUPPORT
2202
2203Crossfire maintains a very simple database for extension use. It can
2204currently store anything that can be serialised using Storable, which
2205excludes objects.
2206
2207The parameter C<$family> should best start with the name of the extension
2208using it, it should be unique.
2209
2210=over 4
2211
2212=item $value = cf::db_get $family => $key
2213
2214Returns a single value from the database.
2215
2216=item cf::db_put $family => $key => $value
2217
2218Stores the given C<$value> in the family.
2219
2220=cut
2221
2222our $DB;
2223
2224sub db_init {
2225 unless ($DB) {
2226 $DB = BDB::db_create $DB_ENV;
2227
2228 cf::sync_job {
2229 eval {
2230 $DB->set_flags (BDB::CHKSUM);
2231
2232 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2233 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2234 cf::cleanup "db_open(db): $!" if $!;
2235 };
2236 cf::cleanup "db_open(db): $@" if $@;
2237 };
2238
2239 my $path = cf::localdir . "/database.pst";
2240 if (stat $path) {
2241 cf::sync_job {
2242 my $pst = Storable::retrieve $path;
2243
2244 cf::db_put (board => data => $pst->{board});
2245 cf::db_put (guildrules => data => $pst->{guildrules});
2246 cf::db_put (rent => balance => $pst->{rent}{balance});
2247 BDB::db_env_txn_checkpoint $DB_ENV;
2248
2249 unlink $path;
2250 };
2251 }
2252 }
2253}
2254
2255sub db_get($$) {
2256 my $key = "$_[0]/$_[1]";
2257
2258 cf::sync_job {
2259 BDB::db_get $DB, undef, $key, my $data;
2260
2261 $! ? ()
2262 : Compress::LZF::sthaw $data
2263 }
2264}
2265
2266sub db_put($$$) {
2267 BDB::dbreq_pri 4;
2268 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2269}
2270
2271#############################################################################
2272# the server's init and main functions 3004# the server's init and main functions
2273 3005
2274sub load_faces { 3006sub load_facedata($) {
2275 my $path = sprintf "%s/faces", cf::datadir; 3007 my ($path) = @_;
2276 3008
3009 # HACK to clear player env face cache, we need some signal framework
3010 # for this (global event?)
3011 %ext::player_env::MUSIC_FACE_CACHE = ();
3012
3013 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3014
2277 warn "loading faces from $path\n"; 3015 warn "loading facedata from $path\n";
2278 3016
2279 my $faces; 3017 my $facedata;
2280 0 < aio_load $path, $faces 3018 0 < aio_load $path, $facedata
2281 or die "$path: $!"; 3019 or die "$path: $!";
2282 3020
2283 Coro::cede;
2284 $faces = Storable::thaw $faces; 3021 $facedata = Coro::Storable::thaw $facedata;
2285 Coro::cede;
2286 3022
3023 $facedata->{version} == 2
3024 or cf::cleanup "$path: version mismatch, cannot proceed.";
3025
3026 # patch in the exptable
3027 $facedata->{resource}{"res/exp_table"} = {
3028 type => FT_RSRC,
3029 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3030 };
3031 cf::cede_to_tick;
3032
3033 {
3034 my $faces = $facedata->{faceinfo};
3035
2287 while (my ($face, $info) = each %$faces) { 3036 while (my ($face, $info) = each %$faces) {
2288 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3037 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2289 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3038 cf::face::set_visibility $idx, $info->{visibility};
3039 cf::face::set_magicmap $idx, $info->{magicmap};
2290 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3040 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2291 Coro::cede; 3041 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3042
3043 cf::cede_to_tick;
3044 }
3045
3046 while (my ($face, $info) = each %$faces) {
3047 next unless $info->{smooth};
3048 my $idx = cf::face::find $face
3049 or next;
3050 if (my $smooth = cf::face::find $info->{smooth}) {
3051 cf::face::set_smooth $idx, $smooth;
3052 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3053 } else {
3054 warn "smooth face '$info->{smooth}' not found for face '$face'";
3055 }
3056
3057 cf::cede_to_tick;
3058 }
3059 }
3060
3061 {
3062 my $anims = $facedata->{animinfo};
3063
3064 while (my ($anim, $info) = each %$anims) {
3065 cf::anim::set $anim, $info->{frames}, $info->{facings};
3066 cf::cede_to_tick;
3067 }
3068
3069 cf::anim::invalidate_all; # d'oh
3070 }
3071
3072 {
3073 # TODO: for gcfclient pleasure, we should give resources
3074 # that gcfclient doesn't grok a >10000 face index.
3075 my $res = $facedata->{resource};
3076
3077 my $soundconf = delete $res->{"res/sound.conf"};
3078
3079 while (my ($name, $info) = each %$res) {
3080 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3081 my $data;
3082
3083 if ($info->{type} & 1) {
3084 # prepend meta info
3085
3086 my $meta = $enc->encode ({
3087 name => $name,
3088 %{ $info->{meta} || {} },
3089 });
3090
3091 $data = pack "(w/a*)*", $meta, $info->{data};
3092 } else {
3093 $data = $info->{data};
3094 }
3095
3096 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3097 cf::face::set_type $idx, $info->{type};
3098
3099 cf::cede_to_tick;
3100 }
3101
3102 if ($soundconf) {
3103 $soundconf = $enc->decode (delete $soundconf->{data});
3104
3105 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3106 my $sound = $soundconf->{compat}[$_]
3107 or next;
3108
3109 my $face = cf::face::find "sound/$sound->[1]";
3110 cf::sound::set $sound->[0] => $face;
3111 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3112 }
3113
3114 while (my ($k, $v) = each %{$soundconf->{event}}) {
3115 my $face = cf::face::find "sound/$v";
3116 cf::sound::set $k => $face;
3117 }
3118 }
2292 } 3119 }
2293 3120
2294 1 3121 1
2295} 3122}
2296 3123
3124register_exticmd fx_want => sub {
3125 my ($ns, $want) = @_;
3126
3127 while (my ($k, $v) = each %$want) {
3128 $ns->fx_want ($k, $v);
3129 }
3130};
3131
3132sub reload_regions {
3133 # HACK to clear player env face cache, we need some signal framework
3134 # for this (global event?)
3135 %ext::player_env::MUSIC_FACE_CACHE = ();
3136
3137 load_resource_file "$MAPDIR/regions"
3138 or die "unable to load regions file\n";
3139
3140 for (cf::region::list) {
3141 $_->{match} = qr/$_->{match}/
3142 if exists $_->{match};
3143 }
3144}
3145
3146sub reload_facedata {
3147 load_facedata "$DATADIR/facedata"
3148 or die "unable to load facedata\n";
3149}
3150
3151sub reload_archetypes {
3152 load_resource_file "$DATADIR/archetypes"
3153 or die "unable to load archetypes\n";
3154 #d# NEED to laod twice to resolve forward references
3155 # this really needs to be done in an extra post-pass
3156 # (which needs to be synchronous, so solve it differently)
3157 load_resource_file "$DATADIR/archetypes"
3158 or die "unable to load archetypes\n";
3159}
3160
3161sub reload_treasures {
3162 load_resource_file "$DATADIR/treasures"
3163 or die "unable to load treasurelists\n";
3164}
3165
2297sub reload_resources { 3166sub reload_resources {
2298 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 3167 warn "reloading resource files...\n";
2299 or die "unable to load regions file\n";#d# 3168
3169 reload_regions;
2300 load_faces 3170 reload_facedata;
2301 or die "unable to load faces\n";#d# 3171 #reload_archetypes;#d#
3172 reload_archetypes;
3173 reload_treasures;
3174
3175 warn "finished reloading resource files\n";
2302} 3176}
2303 3177
2304sub init { 3178sub init {
2305 reload_resources; 3179 reload_resources;
2306} 3180}
2307 3181
2308sub cfg_load { 3182sub reload_config {
2309 open my $fh, "<:utf8", cf::confdir . "/config" 3183 open my $fh, "<:utf8", "$CONFDIR/config"
2310 or return; 3184 or return;
2311 3185
2312 local $/; 3186 local $/;
2313 *CFG = YAML::Syck::Load <$fh>; 3187 *CFG = YAML::Syck::Load <$fh>;
2314 3188
… …
2329sub main { 3203sub main {
2330 # we must not ever block the main coroutine 3204 # we must not ever block the main coroutine
2331 local $Coro::idle = sub { 3205 local $Coro::idle = sub {
2332 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3206 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2333 (async { 3207 (async {
3208 $Coro::current->{desc} = "IDLE BUG HANDLER";
2334 Event::one_event; 3209 Event::one_event;
2335 })->prio (Coro::PRIO_MAX); 3210 })->prio (Coro::PRIO_MAX);
2336 }; 3211 };
2337 3212
2338 cfg_load; 3213 reload_config;
2339 db_init; 3214 db_init;
2340 load_extensions; 3215 load_extensions;
2341 3216
2342 $TICK_WATCHER->start; 3217 $TICK_WATCHER->start;
2343 Event::loop; 3218 Event::loop;
… …
2359 }, 3234 },
2360 ); 3235 );
2361 } 3236 }
2362} 3237}
2363 3238
3239sub write_runtime {
3240 my $runtime = "$LOCALDIR/runtime";
3241
3242 # first touch the runtime file to show we are still running:
3243 # the fsync below can take a very very long time.
3244
3245 IO::AIO::aio_utime $runtime, undef, undef;
3246
3247 my $guard = cf::lock_acquire "write_runtime";
3248
3249 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3250 or return;
3251
3252 my $value = $cf::RUNTIME + 90 + 10;
3253 # 10 is the runtime save interval, for a monotonic clock
3254 # 60 allows for the watchdog to kill the server.
3255
3256 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3257 and return;
3258
3259 # always fsync - this file is important
3260 aio_fsync $fh
3261 and return;
3262
3263 # touch it again to show we are up-to-date
3264 aio_utime $fh, undef, undef;
3265
3266 close $fh
3267 or return;
3268
3269 aio_rename "$runtime~", $runtime
3270 and return;
3271
3272 warn "runtime file written.\n";
3273
3274 1
3275}
3276
2364sub emergency_save() { 3277sub emergency_save() {
2365 my $freeze_guard = cf::freeze_mainloop; 3278 my $freeze_guard = cf::freeze_mainloop;
2366 3279
2367 warn "enter emergency perl save\n"; 3280 warn "enter emergency perl save\n";
2368 3281
… …
2372 # and maps saved/destroyed asynchronously. 3285 # and maps saved/destroyed asynchronously.
2373 warn "begin emergency player save\n"; 3286 warn "begin emergency player save\n";
2374 for my $login (keys %cf::PLAYER) { 3287 for my $login (keys %cf::PLAYER) {
2375 my $pl = $cf::PLAYER{$login} or next; 3288 my $pl = $cf::PLAYER{$login} or next;
2376 $pl->valid or next; 3289 $pl->valid or next;
3290 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
2377 $pl->save; 3291 $pl->save;
2378 } 3292 }
2379 warn "end emergency player save\n"; 3293 warn "end emergency player save\n";
2380 3294
2381 warn "begin emergency map save\n"; 3295 warn "begin emergency map save\n";
… …
2399 3313
2400 warn Carp::longmess "post_cleanup backtrace" 3314 warn Carp::longmess "post_cleanup backtrace"
2401 if $make_core; 3315 if $make_core;
2402} 3316}
2403 3317
2404sub reload() { 3318sub do_reload_perl() {
2405 # can/must only be called in main 3319 # can/must only be called in main
2406 if ($Coro::current != $Coro::main) { 3320 if ($Coro::current != $Coro::main) {
2407 warn "can only reload from main coroutine"; 3321 warn "can only reload from main coroutine";
2408 return; 3322 return;
2409 } 3323 }
… …
2443 %EXT_CORO = (); 3357 %EXT_CORO = ();
2444 3358
2445 warn "removing commands"; 3359 warn "removing commands";
2446 %COMMAND = (); 3360 %COMMAND = ();
2447 3361
2448 warn "removing ext commands"; 3362 warn "removing ext/exti commands";
2449 %EXTCMD = (); 3363 %EXTCMD = ();
3364 %EXTICMD = ();
2450 3365
2451 warn "unloading/nuking all extensions"; 3366 warn "unloading/nuking all extensions";
2452 for my $pkg (@EXTS) { 3367 for my $pkg (@EXTS) {
2453 warn "... unloading $pkg"; 3368 warn "... unloading $pkg";
2454 3369
… …
2484 Symbol::delete_package "safe::$_" 3399 Symbol::delete_package "safe::$_"
2485 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3400 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2486 3401
2487 warn "unloading cf.pm \"a bit\""; 3402 warn "unloading cf.pm \"a bit\"";
2488 delete $INC{"cf.pm"}; 3403 delete $INC{"cf.pm"};
3404 delete $INC{"cf/pod.pm"};
2489 3405
2490 # don't, removes xs symbols, too, 3406 # don't, removes xs symbols, too,
2491 # and global variables created in xs 3407 # and global variables created in xs
2492 #Symbol::delete_package __PACKAGE__; 3408 #Symbol::delete_package __PACKAGE__;
2493 3409
… …
2496 warn "reloading cf.pm"; 3412 warn "reloading cf.pm";
2497 require cf; 3413 require cf;
2498 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3414 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2499 3415
2500 warn "loading config and database again"; 3416 warn "loading config and database again";
2501 cf::cfg_load; 3417 cf::reload_config;
2502 3418
2503 warn "loading extensions"; 3419 warn "loading extensions";
2504 cf::load_extensions; 3420 cf::load_extensions;
2505 3421
2506 warn "reattaching attachments to objects/players"; 3422 warn "reattaching attachments to objects/players";
… …
2508 warn "reattaching attachments to maps"; 3424 warn "reattaching attachments to maps";
2509 reattach $_ for values %MAP; 3425 reattach $_ for values %MAP;
2510 warn "reattaching attachments to players"; 3426 warn "reattaching attachments to players";
2511 reattach $_ for values %PLAYER; 3427 reattach $_ for values %PLAYER;
2512 3428
2513 warn "loading reloadable resources";
2514 reload_resources;
2515
2516 warn "leaving sync_job"; 3429 warn "leaving sync_job";
2517 3430
2518 1 3431 1
2519 } or do { 3432 } or do {
2520 warn $@; 3433 warn $@;
… …
2525 warn "reloaded"; 3438 warn "reloaded";
2526}; 3439};
2527 3440
2528our $RELOAD_WATCHER; # used only during reload 3441our $RELOAD_WATCHER; # used only during reload
2529 3442
3443sub reload_perl() {
3444 # doing reload synchronously and two reloads happen back-to-back,
3445 # coro crashes during coro_state_free->destroy here.
3446
3447 $RELOAD_WATCHER ||= Event->timer (
3448 reentrant => 0,
3449 after => 0,
3450 data => WF_AUTOCANCEL,
3451 cb => sub {
3452 do_reload_perl;
3453 undef $RELOAD_WATCHER;
3454 },
3455 );
3456}
3457
2530register_command "reload" => sub { 3458register_command "reload" => sub {
2531 my ($who, $arg) = @_; 3459 my ($who, $arg) = @_;
2532 3460
2533 if ($who->flag (FLAG_WIZ)) { 3461 if ($who->flag (FLAG_WIZ)) {
2534 $who->message ("reloading server."); 3462 $who->message ("reloading server.");
2535 3463 async {
2536 # doing reload synchronously and two reloads happen back-to-back, 3464 $Coro::current->{desc} = "perl_reload";
2537 # coro crashes during coro_state_free->destroy here.
2538
2539 $RELOAD_WATCHER ||= Event->timer (
2540 reentrant => 0,
2541 after => 0,
2542 data => WF_AUTOCANCEL,
2543 cb => sub {
2544 reload; 3465 reload_perl;
2545 undef $RELOAD_WATCHER;
2546 },
2547 ); 3466 };
2548 } 3467 }
2549}; 3468};
2550 3469
2551unshift @INC, $LIBDIR; 3470unshift @INC, $LIBDIR;
2552 3471
2553my $bug_warning = 0; 3472my $bug_warning = 0;
3473
3474our @WAIT_FOR_TICK;
3475our @WAIT_FOR_TICK_BEGIN;
3476
3477sub wait_for_tick {
3478 return unless $TICK_WATCHER->is_active;
3479 return if $Coro::current == $Coro::main;
3480
3481 my $signal = new Coro::Signal;
3482 push @WAIT_FOR_TICK, $signal;
3483 $signal->wait;
3484}
3485
3486sub wait_for_tick_begin {
3487 return unless $TICK_WATCHER->is_active;
3488 return if $Coro::current == $Coro::main;
3489
3490 my $signal = new Coro::Signal;
3491 push @WAIT_FOR_TICK_BEGIN, $signal;
3492 $signal->wait;
3493}
2554 3494
2555$TICK_WATCHER = Event->timer ( 3495$TICK_WATCHER = Event->timer (
2556 reentrant => 0, 3496 reentrant => 0,
2557 parked => 1, 3497 parked => 1,
2558 prio => 0, 3498 prio => 0,
… …
2563 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3503 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2564 unless ++$bug_warning > 10; 3504 unless ++$bug_warning > 10;
2565 return; 3505 return;
2566 } 3506 }
2567 3507
2568 $NOW = Event::time; 3508 $NOW = $tick_start = Event::time;
2569 3509
2570 cf::server_tick; # one server iteration 3510 cf::server_tick; # one server iteration
3511
2571 $RUNTIME += $TICK; 3512 $RUNTIME += $TICK;
2572 $NEXT_TICK += $TICK; 3513 $NEXT_TICK += $TICK;
2573 3514
2574 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3515 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2575 $NEXT_RUNTIME_WRITE = $NOW + 10; 3516 $NEXT_RUNTIME_WRITE = $NOW + 10;
2576 Coro::async_pool { 3517 Coro::async_pool {
3518 $Coro::current->{desc} = "runtime saver";
2577 write_runtime 3519 write_runtime
2578 or warn "ERROR: unable to write runtime file: $!"; 3520 or warn "ERROR: unable to write runtime file: $!";
2579 }; 3521 };
2580 } 3522 }
2581 3523
2582 $WAIT_FOR_TICK->broadcast; 3524 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2583 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 3525 $sig->send;
3526 }
3527 while (my $sig = shift @WAIT_FOR_TICK) {
3528 $sig->send;
3529 }
2584 3530
2585# my $AFTER = Event::time; 3531 $NOW = Event::time;
2586# warn $AFTER - $NOW;#d#
2587 3532
2588 # if we are delayed by four ticks or more, skip them all 3533 # if we are delayed by four ticks or more, skip them all
2589 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3534 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2590 3535
2591 $TICK_WATCHER->at ($NEXT_TICK); 3536 $TICK_WATCHER->at ($NEXT_TICK);
2592 $TICK_WATCHER->start; 3537 $TICK_WATCHER->start;
3538
3539 $LOAD = ($NOW - $tick_start) / $TICK;
3540 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3541
3542 _post_tick;
2593 }, 3543 },
2594); 3544);
2595 3545
2596{ 3546{
3547 BDB::min_parallel 8;
2597 BDB::max_poll_time $TICK * 0.1; 3548 BDB::max_poll_time $TICK * 0.1;
2598 $BDB_POLL_WATCHER = Event->io ( 3549 $BDB_POLL_WATCHER = Event->io (
2599 reentrant => 0, 3550 reentrant => 0,
2600 fd => BDB::poll_fileno, 3551 fd => BDB::poll_fileno,
2601 poll => 'r', 3552 poll => 'r',
2602 prio => 0, 3553 prio => 0,
2603 data => WF_AUTOCANCEL, 3554 data => WF_AUTOCANCEL,
2604 cb => \&BDB::poll_cb, 3555 cb => \&BDB::poll_cb,
2605 ); 3556 );
2606 BDB::min_parallel 8;
2607 3557
2608 BDB::set_sync_prepare { 3558 BDB::set_sync_prepare {
2609 my $status; 3559 my $status;
2610 my $current = $Coro::current; 3560 my $current = $Coro::current;
2611 ( 3561 (
… …
2620 ) 3570 )
2621 }; 3571 };
2622 3572
2623 unless ($DB_ENV) { 3573 unless ($DB_ENV) {
2624 $DB_ENV = BDB::db_env_create; 3574 $DB_ENV = BDB::db_env_create;
3575 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3576 | BDB::LOG_AUTOREMOVE, 1);
3577 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3578 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2625 3579
2626 cf::sync_job { 3580 cf::sync_job {
2627 eval { 3581 eval {
2628 BDB::db_env_open 3582 BDB::db_env_open
2629 $DB_ENV, 3583 $DB_ENV,
2630 $BDB_ENV_DIR, 3584 $BDBDIR,
2631 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3585 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2632 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3586 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2633 0666; 3587 0666;
2634 3588
2635 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3589 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2636
2637 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2638 $DB_ENV->set_lk_detect;
2639 }; 3590 };
2640 3591
2641 cf::cleanup "db_env_open(db): $@" if $@; 3592 cf::cleanup "db_env_open(db): $@" if $@;
2642 }; 3593 };
2643 } 3594 }
3595
3596 $BDB_DEADLOCK_WATCHER = Event->timer (
3597 after => 3,
3598 interval => 1,
3599 hard => 1,
3600 prio => 0,
3601 data => WF_AUTOCANCEL,
3602 cb => sub {
3603 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3604 },
3605 );
3606 $BDB_CHECKPOINT_WATCHER = Event->timer (
3607 after => 11,
3608 interval => 60,
3609 hard => 1,
3610 prio => 0,
3611 data => WF_AUTOCANCEL,
3612 cb => sub {
3613 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3614 },
3615 );
3616 $BDB_TRICKLE_WATCHER = Event->timer (
3617 after => 5,
3618 interval => 10,
3619 hard => 1,
3620 prio => 0,
3621 data => WF_AUTOCANCEL,
3622 cb => sub {
3623 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3624 },
3625 );
2644} 3626}
2645 3627
2646{ 3628{
2647 IO::AIO::min_parallel 8; 3629 IO::AIO::min_parallel 8;
2648 3630
… …
2651 $AIO_POLL_WATCHER = Event->io ( 3633 $AIO_POLL_WATCHER = Event->io (
2652 reentrant => 0, 3634 reentrant => 0,
2653 data => WF_AUTOCANCEL, 3635 data => WF_AUTOCANCEL,
2654 fd => IO::AIO::poll_fileno, 3636 fd => IO::AIO::poll_fileno,
2655 poll => 'r', 3637 poll => 'r',
2656 prio => 6, 3638 prio => 0,
2657 cb => \&IO::AIO::poll_cb, 3639 cb => \&IO::AIO::poll_cb,
2658 ); 3640 );
2659} 3641}
2660 3642
3643my $_log_backtrace;
3644
3645sub _log_backtrace {
3646 my ($msg, @addr) = @_;
3647
3648 $msg =~ s/\n//;
3649
3650 # limit the # of concurrent backtraces
3651 if ($_log_backtrace < 2) {
3652 ++$_log_backtrace;
3653 async {
3654 $Coro::current->{desc} = "abt $msg";
3655
3656 my @bt = fork_call {
3657 @addr = map { sprintf "%x", $_ } @addr;
3658 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3659 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3660 or die "addr2line: $!";
3661
3662 my @funcs;
3663 my @res = <$fh>;
3664 chomp for @res;
3665 while (@res) {
3666 my ($func, $line) = splice @res, 0, 2, ();
3667 push @funcs, "[$func] $line";
3668 }
3669
3670 @funcs
3671 };
3672
3673 LOG llevInfo, "[ABT] $msg\n";
3674 LOG llevInfo, "[ABT] $_\n" for @bt;
3675 --$_log_backtrace;
3676 };
3677 } else {
3678 LOG llevInfo, "[ABT] $msg\n";
3679 LOG llevInfo, "[ABT] [suppressed]\n";
3680 }
3681}
3682
3683# load additional modules
3684use cf::pod;
3685
2661END { cf::emergency_save } 3686END { cf::emergency_save }
2662 3687
26631 36881
2664 3689

Diff Legend

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