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.219 by root, Sat Feb 17 03:19:44 2007 UTC vs.
Revision 1.372 by root, Sat Sep 15 13:25:33 2007 UTC

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

Diff Legend

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