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.215 by root, Thu Feb 15 03:19:02 2007 UTC vs.
Revision 1.379 by root, Thu Oct 4 23:59:07 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 $Coro::current->desc ("timeslot manager");
360
361 my $signal = new Coro::Signal;
362
363 while () {
364 next_job:
365 my $avail = cf::till_tick;
366 if ($avail > 0.01) {
367 for (0 .. $#SLOT_QUEUE) {
368 if ($SLOT_QUEUE[$_][0] < $avail) {
369 my $job = splice @SLOT_QUEUE, $_, 1, ();
370 $job->[2]->send;
371 Coro::cede;
372 goto next_job;
373 }
374 }
375 }
376
377 if (@SLOT_QUEUE) {
378 # we do not use wait_For_tick() as it returns immediately when tick is inactive
379 push @cf::WAIT_FOR_TICK, $signal;
380 $signal->wait;
381 } else {
382 Coro::schedule;
383 }
384 }
385};
386
387sub get_slot($;$$) {
388 my ($time, $pri, $name) = @_;
389
390 $time = $TICK * .6 if $time > $TICK * .6;
391 my $sig = new Coro::Signal;
392
393 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
394 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
395 $SLOT_QUEUE->ready;
396 $sig->wait;
397}
398
283=item cf::async { BLOCK } 399=item cf::async { BLOCK }
284 400
285Currently the same as Coro::async_pool, meaning you cannot use 401Currently the same as Coro::async_pool, meaning you cannot use
286C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 402C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
287thing you are allowed to do is call C<prio> on it. 403thing you are allowed to do is call C<prio> on it.
… …
290 406
291BEGIN { *async = \&Coro::async_pool } 407BEGIN { *async = \&Coro::async_pool }
292 408
293=item cf::sync_job { BLOCK } 409=item cf::sync_job { BLOCK }
294 410
295The design of crossfire+ requires that the main coro ($Coro::main) is 411The design of Crossfire TRT requires that the main coroutine ($Coro::main)
296always able to handle events or runnable, as crossfire+ is only partly 412is 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. 413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable.
298 415
299If it must be done, put the blocking parts into C<sync_job>. This will run 416If it must be done, put the blocking parts into C<sync_job>. This will run
300the given BLOCK in another coroutine while waiting for the result. The 417the given BLOCK in another coroutine while waiting for the result. The
301server will be frozen during this time, so the block should either finish 418server will be frozen during this time, so the block should either finish
302fast or be very important. 419fast or be very important.
… …
305 422
306sub sync_job(&) { 423sub sync_job(&) {
307 my ($job) = @_; 424 my ($job) = @_;
308 425
309 if ($Coro::current == $Coro::main) { 426 if ($Coro::current == $Coro::main) {
427 my $time = Event::time;
428
310 # this is the main coro, too bad, we have to block 429 # this is the main coro, too bad, we have to block
311 # till the operation succeeds, freezing the server :/ 430 # till the operation succeeds, freezing the server :/
312 431
432 LOG llevError | logBacktrace, Carp::longmess "sync job";#d#
433
313 # TODO: use suspend/resume instead 434 # TODO: use suspend/resume instead
314 # (but this is cancel-safe) 435 # (but this is cancel-safe)
315 my $freeze_guard = freeze_mainloop; 436 my $freeze_guard = freeze_mainloop;
316 437
317 my $busy = 1; 438 my $busy = 1;
318 my @res; 439 my @res;
319 440
320 (async { 441 (async {
442 $Coro::current->desc ("sync job coro");
321 @res = eval { $job->() }; 443 @res = eval { $job->() };
322 warn $@ if $@; 444 warn $@ if $@;
323 undef $busy; 445 undef $busy;
324 })->prio (Coro::PRIO_MAX); 446 })->prio (Coro::PRIO_MAX);
325 447
326 while ($busy) { 448 while ($busy) {
327 Coro::cede or Event::one_event; 449 Coro::cede or Event::one_event;
328 } 450 }
451
452 $time = Event::time - $time;
453
454 LOG llevError | logBacktrace, Carp::longmess "long sync job"
455 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
456
457 $tick_start += $time; # do not account sync jobs to server load
329 458
330 wantarray ? @res : $res[0] 459 wantarray ? @res : $res[0]
331 } else { 460 } else {
332 # we are in another coroutine, how wonderful, everything just works 461 # we are in another coroutine, how wonderful, everything just works
333 462
… …
353 $EXT_CORO{$coro+0} = $coro; 482 $EXT_CORO{$coro+0} = $coro;
354 483
355 $coro 484 $coro
356} 485}
357 486
358sub write_runtime { 487=item fork_call { }, $args
359 my $runtime = cf::localdir . "/runtime";
360 488
361 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 489Executes the given code block with the given arguments in a seperate
362 or return; 490process, returning the results. Everything must be serialisable with
491Coro::Storable. May, of course, block. Note that the executed sub may
492never block itself or use any form of Event handling.
363 493
364 my $value = $cf::RUNTIME + 90 + 10; 494=cut
365 # 10 is the runtime save interval, for a monotonic clock
366 # 60 allows for the watchdog to kill the server.
367 495
368 (aio_write $fh, 0, (length $value), $value, 0) <= 0 496sub fork_call(&@) {
369 and return; 497 my ($cb, @args) = @_;
370 498
371 # always fsync - this file is important 499 # we seemingly have to make a local copy of the whole thing,
372 aio_fsync $fh 500 # otherwise perl prematurely frees the stuff :/
373 and return; 501 # TODO: investigate and fix (likely this will be rather laborious)
374 502
375 close $fh 503 my @res = Coro::Util::fork_eval {
376 or return; 504 reset_signals;
505 &$cb
506 }, @args;
377 507
378 aio_rename "$runtime~", $runtime 508 wantarray ? @res : $res[-1]
379 and return; 509}
380 510
511=item $value = cf::db_get $family => $key
512
513Returns a single value from the environment database.
514
515=item cf::db_put $family => $key => $value
516
517Stores the given C<$value> in the family. It can currently store binary
518data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
519
520=item $db = cf::db_table "name"
521
522Create and/or open a new database table. The string must not be "db" and must be unique
523within each server.
524
525=cut
526
527sub db_table($) {
528 my ($name) = @_;
529 my $db = BDB::db_create $DB_ENV;
530
531 eval {
532 $db->set_flags (BDB::CHKSUM);
533
534 utf8::encode $name;
535 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
536 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
537 cf::cleanup "db_open(db): $!" if $!;
538 };
539 cf::cleanup "db_open(db): $@" if $@;
540
541 $db
542}
543
544our $DB;
545
546sub db_init {
547 cf::sync_job {
548 $DB ||= db_table "db";
549 };
550}
551
552sub db_get($$) {
553 my $key = "$_[0]/$_[1]";
554
555 cf::sync_job {
556 BDB::db_get $DB, undef, $key, my $data;
557
558 $! ? ()
559 : $data
381 1 560 }
561}
562
563sub db_put($$$) {
564 BDB::dbreq_pri 4;
565 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
566}
567
568=item cf::cache $id => [$paths...], $processversion => $process
569
570Generic caching function that returns the value of the resource $id,
571caching and regenerating as required.
572
573This function can block.
574
575=cut
576
577sub cache {
578 my ($id, $src, $processversion, $process) = @_;
579
580 my $meta =
581 join "\x00",
582 $processversion,
583 map {
584 aio_stat $_
585 and Carp::croak "$_: $!";
586
587 ($_, (stat _)[7,9])
588 } @$src;
589
590 my $dbmeta = db_get cache => "$id/meta";
591 if ($dbmeta ne $meta) {
592 # changed, we may need to process
593
594 my @data;
595 my $md5;
596
597 for (0 .. $#$src) {
598 0 <= aio_load $src->[$_], $data[$_]
599 or Carp::croak "$src->[$_]: $!";
600 }
601
602 # if processing is expensive, check
603 # checksum first
604 if (1) {
605 $md5 =
606 join "\x00",
607 $processversion,
608 map {
609 cf::cede_to_tick;
610 ($src->[$_], Digest::MD5::md5_hex $data[$_])
611 } 0.. $#$src;
612
613
614 my $dbmd5 = db_get cache => "$id/md5";
615 if ($dbmd5 eq $md5) {
616 db_put cache => "$id/meta", $meta;
617
618 return db_get cache => "$id/data";
619 }
620 }
621
622 my $t1 = Time::HiRes::time;
623 my $data = $process->(\@data);
624 my $t2 = Time::HiRes::time;
625
626 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
627
628 db_put cache => "$id/data", $data;
629 db_put cache => "$id/md5" , $md5;
630 db_put cache => "$id/meta", $meta;
631
632 return $data;
633 }
634
635 db_get cache => "$id/data"
636}
637
638=item cf::datalog type => key => value, ...
639
640Log a datalog packet of the given type with the given key-value pairs.
641
642=cut
643
644sub datalog($@) {
645 my ($type, %kv) = @_;
646 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
382} 647}
383 648
384=back 649=back
385 650
386=cut 651=cut
… …
393attach callbacks/event handlers (a collection of which is called an "attachment") 658attach callbacks/event handlers (a collection of which is called an "attachment")
394to it. All such attachable objects support the following methods. 659to it. All such attachable objects support the following methods.
395 660
396In the following description, CLASS can be any of C<global>, C<object> 661In the following description, CLASS can be any of C<global>, C<object>
397C<player>, C<client> or C<map> (i.e. the attachable objects in 662C<player>, C<client> or C<map> (i.e. the attachable objects in
398crossfire+). 663Crossfire TRT).
399 664
400=over 4 665=over 4
401 666
402=item $attachable->attach ($attachment, key => $value...) 667=item $attachable->attach ($attachment, key => $value...)
403 668
… …
566 $registry = $CB_TYPE[$object_type] ||= []; 831 $registry = $CB_TYPE[$object_type] ||= [];
567 832
568 } elsif ($type eq "subtype") { 833 } elsif ($type eq "subtype") {
569 defined $object_type or Carp::croak "subtype specified without type"; 834 defined $object_type or Carp::croak "subtype specified without type";
570 my $object_subtype = shift @arg; 835 my $object_subtype = shift @arg;
571 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 836 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
572 837
573 } elsif ($type eq "package") { 838 } elsif ($type eq "package") {
574 my $pkg = shift @arg; 839 my $pkg = shift @arg;
575 840
576 while (my ($name, $id) = each %cb_id) { 841 while (my ($name, $id) = each %cb_id) {
… …
605 _attach $registry, $klass, @attach; 870 _attach $registry, $klass, @attach;
606 } 871 }
607 872
608 $obj->{$name} = \%arg; 873 $obj->{$name} = \%arg;
609 } else { 874 } else {
610 warn "object uses attachment '$name' that is not available, postponing.\n"; 875 warn "object uses attachment '$name' which is not available, postponing.\n";
611 } 876 }
612 877
613 $obj->{_attachment}{$name} = undef; 878 $obj->{_attachment}{$name} = undef;
614} 879}
615 880
… …
617 if (ref $_[0]) { 882 if (ref $_[0]) {
618 _object_attach @_; 883 _object_attach @_;
619 } else { 884 } else {
620 _attach shift->_attach_registry, @_; 885 _attach shift->_attach_registry, @_;
621 } 886 }
887 _recalc_want;
622}; 888};
623 889
624# all those should be optimised 890# all those should be optimised
625sub cf::attachable::detach { 891sub cf::attachable::detach {
626 my ($obj, $name) = @_; 892 my ($obj, $name) = @_;
… …
629 delete $obj->{_attachment}{$name}; 895 delete $obj->{_attachment}{$name};
630 reattach ($obj); 896 reattach ($obj);
631 } else { 897 } else {
632 Carp::croak "cannot, currently, detach class attachments"; 898 Carp::croak "cannot, currently, detach class attachments";
633 } 899 }
900 _recalc_want;
634}; 901};
635 902
636sub cf::attachable::attached { 903sub cf::attachable::attached {
637 my ($obj, $name) = @_; 904 my ($obj, $name) = @_;
638 905
… …
653 "; 920 ";
654 die if $@; 921 die if $@;
655} 922}
656 923
657our $override; 924our $override;
658our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 925our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
659 926
660sub override { 927sub override {
661 $override = 1; 928 $override = 1;
662 @invoke_results = (); 929 @INVOKE_RESULTS = (@_);
663} 930}
664 931
665sub do_invoke { 932sub do_invoke {
666 my $event = shift; 933 my $event = shift;
667 my $callbacks = shift; 934 my $callbacks = shift;
668 935
669 @invoke_results = (); 936 @INVOKE_RESULTS = ();
670 937
671 local $override; 938 local $override;
672 939
673 for (@$callbacks) { 940 for (@$callbacks) {
674 eval { &{$_->[1]} }; 941 eval { &{$_->[1]} };
… …
691 958
692Generate an object-specific event with the given arguments. 959Generate an object-specific event with the given arguments.
693 960
694This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 961This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
695removed in future versions), and there is no public API to access override 962removed in future versions), and there is no public API to access override
696results (if you must, access C<@cf::invoke_results> directly). 963results (if you must, access C<@cf::INVOKE_RESULTS> directly).
697 964
698=back 965=back
699 966
700=cut 967=cut
701 968
702############################################################################# 969#############################################################################
703# object support 970# object support
971#
972
973sub _can_merge {
974 my ($ob1, $ob2) = @_;
975
976 local $Storable::canonical = 1;
977 my $fob1 = Storable::freeze $ob1;
978 my $fob2 = Storable::freeze $ob2;
979
980 $fob1 eq $fob2
981}
704 982
705sub reattach { 983sub reattach {
706 # basically do the same as instantiate, without calling instantiate 984 # basically do the same as instantiate, without calling instantiate
707 my ($obj) = @_; 985 my ($obj) = @_;
708 986
… …
755sub object_freezer_save { 1033sub object_freezer_save {
756 my ($filename, $rdata, $objs) = @_; 1034 my ($filename, $rdata, $objs) = @_;
757 1035
758 sync_job { 1036 sync_job {
759 if (length $$rdata) { 1037 if (length $$rdata) {
1038 utf8::decode (my $decname = $filename);
760 warn sprintf "saving %s (%d,%d)\n", 1039 warn sprintf "saving %s (%d,%d)\n",
761 $filename, length $$rdata, scalar @$objs; 1040 $decname, length $$rdata, scalar @$objs;
762 1041
763 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1042 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
764 chmod SAVE_MODE, $fh; 1043 chmod SAVE_MODE, $fh;
765 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1044 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
766 aio_fsync $fh if $cf::USE_FSYNC; 1045 aio_fsync $fh if $cf::USE_FSYNC;
… …
785 } 1064 }
786 } else { 1065 } else {
787 aio_unlink $filename; 1066 aio_unlink $filename;
788 aio_unlink "$filename.pst"; 1067 aio_unlink "$filename.pst";
789 } 1068 }
790
791 #d##TODO# nuke non .map-files if exist
792 if ($filename =~ s/\.map$//) {
793 aio_unlink $filename;
794 aio_unlink "$filename.pst";
795 }
796 } 1069 };
797} 1070}
798 1071
799sub object_freezer_as_string { 1072sub object_freezer_as_string {
800 my ($rdata, $objs) = @_; 1073 my ($rdata, $objs) = @_;
801 1074
… …
806 1079
807sub object_thawer_load { 1080sub object_thawer_load {
808 my ($filename) = @_; 1081 my ($filename) = @_;
809 1082
810 my ($data, $av); 1083 my ($data, $av);
811
812 #d#TODO remove .map if file does not exist
813 aio_stat $filename and $filename =~ s/\.map$//;
814 1084
815 (aio_load $filename, $data) >= 0 1085 (aio_load $filename, $data) >= 0
816 or return; 1086 or return;
817 1087
818 unless (aio_stat "$filename.pst") { 1088 unless (aio_stat "$filename.pst") {
819 (aio_load "$filename.pst", $av) >= 0 1089 (aio_load "$filename.pst", $av) >= 0
820 or return; 1090 or return;
1091
821 $av = eval { (Storable::thaw $av)->{objs} }; 1092 $av = eval { (Storable::thaw $av)->{objs} };
822 } 1093 }
823 1094
1095 utf8::decode (my $decname = $filename);
824 warn sprintf "loading %s (%d)\n", 1096 warn sprintf "loading %s (%d,%d)\n",
825 $filename, length $data, scalar @{$av || []};#d# 1097 $decname, length $data, scalar @{$av || []};
1098
826 return ($data, $av); 1099 ($data, $av)
827} 1100}
1101
1102=head2 COMMAND CALLBACKS
1103
1104=over 4
1105
1106=cut
828 1107
829############################################################################# 1108#############################################################################
830# command handling &c 1109# command handling &c
831 1110
832=item cf::register_command $name => \&callback($ob,$args); 1111=item cf::register_command $name => \&callback($ob,$args);
… …
845 push @{ $COMMAND{$name} }, [$caller, $cb]; 1124 push @{ $COMMAND{$name} }, [$caller, $cb];
846} 1125}
847 1126
848=item cf::register_extcmd $name => \&callback($pl,$packet); 1127=item cf::register_extcmd $name => \&callback($pl,$packet);
849 1128
850Register a callbackf ro execution when the client sends an extcmd packet. 1129Register a callback for execution when the client sends an (synchronous)
1130extcmd packet. Ext commands will be processed in the order they are
1131received by the server, like other user commands. The first argument is
1132the logged-in player. Ext commands can only be processed after a player
1133has logged in successfully.
851 1134
852If the callback returns something, it is sent back as if reply was being 1135If the callback returns something, it is sent back as if reply was being
853called. 1136called.
854 1137
1138=item cf::register_exticmd $name => \&callback($ns,$packet);
1139
1140Register a callback for execution when the client sends an (asynchronous)
1141exticmd packet. Exti commands are processed by the server as soon as they
1142are received, i.e. out of order w.r.t. other commands. The first argument
1143is a client socket. Exti commands can be received anytime, even before
1144log-in.
1145
1146If the callback returns something, it is sent back as if reply was being
1147called.
1148
855=cut 1149=cut
856 1150
857sub register_extcmd { 1151sub register_extcmd {
858 my ($name, $cb) = @_; 1152 my ($name, $cb) = @_;
859 1153
860 $EXTCMD{$name} = $cb; 1154 $EXTCMD{$name} = $cb;
1155}
1156
1157sub register_exticmd {
1158 my ($name, $cb) = @_;
1159
1160 $EXTICMD{$name} = $cb;
861} 1161}
862 1162
863cf::player->attach ( 1163cf::player->attach (
864 on_command => sub { 1164 on_command => sub {
865 my ($pl, $name, $params) = @_; 1165 my ($pl, $name, $params) = @_;
… …
874 cf::override; 1174 cf::override;
875 }, 1175 },
876 on_extcmd => sub { 1176 on_extcmd => sub {
877 my ($pl, $buf) = @_; 1177 my ($pl, $buf) = @_;
878 1178
879 my $msg = eval { from_json $buf }; 1179 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
880 1180
881 if (ref $msg) { 1181 if (ref $msg) {
1182 my ($type, $reply, @payload) =
1183 "ARRAY" eq ref $msg
1184 ? @$msg
1185 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1186
1187 my @reply;
1188
882 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1189 if (my $cb = $EXTCMD{$type}) {
883 if (my %reply = $cb->($pl, $msg)) { 1190 @reply = $cb->($pl, @payload);
884 $pl->ext_reply ($msg->{msgid}, %reply);
885 }
886 } 1191 }
1192
1193 $pl->ext_reply ($reply, @reply)
1194 if $reply;
1195
887 } else { 1196 } else {
888 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1197 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
889 } 1198 }
890 1199
891 cf::override; 1200 cf::override;
892 }, 1201 },
893); 1202);
894 1203
895sub load_extension {
896 my ($path) = @_;
897
898 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
899 my $base = $1;
900 my $pkg = $1;
901 $pkg =~ s/[^[:word:]]/_/g;
902 $pkg = "ext::$pkg";
903
904 warn "... loading '$path' into '$pkg'\n";
905
906 open my $fh, "<:utf8", $path
907 or die "$path: $!";
908
909 my $source =
910 "package $pkg; use strict; use utf8;\n"
911 . "#line 1 \"$path\"\n{\n"
912 . (do { local $/; <$fh> })
913 . "\n};\n1";
914
915 unless (eval $source) {
916 my $msg = $@ ? "$path: $@\n"
917 : "extension disabled.\n";
918 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
919 warn $@;
920 warn "mandatory extension failed to load, exiting.\n";
921 exit 1;
922 }
923 die $@;
924 }
925
926 push @EXTS, $pkg;
927}
928
929sub load_extensions { 1204sub load_extensions {
1205 cf::sync_job {
1206 my %todo;
1207
930 for my $ext (<$LIBDIR/*.ext>) { 1208 for my $path (<$LIBDIR/*.ext>) {
931 next unless -r $ext; 1209 next unless -r $path;
932 eval { 1210
933 load_extension $ext; 1211 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1212 my $base = $1;
1213 my $pkg = $1;
1214 $pkg =~ s/[^[:word:]]/_/g;
1215 $pkg = "ext::$pkg";
1216
1217 open my $fh, "<:utf8", $path
1218 or die "$path: $!";
1219
1220 my $source = do { local $/; <$fh> };
1221
1222 my %ext = (
1223 path => $path,
1224 base => $base,
1225 pkg => $pkg,
1226 );
1227
1228 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1229 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1230
1231 $ext{source} =
1232 "package $pkg; use strict; use utf8;\n"
1233 . "#line 1 \"$path\"\n{\n"
1234 . $source
1235 . "\n};\n1";
1236
1237 $todo{$base} = \%ext;
1238 }
1239
1240 my %done;
1241 while (%todo) {
1242 my $progress;
1243
1244 while (my ($k, $v) = each %todo) {
1245 for (split /,\s*/, $v->{meta}{depends}) {
1246 goto skip
1247 unless exists $done{$_};
1248 }
1249
1250 warn "... loading '$k' into '$v->{pkg}'\n";
1251
1252 unless (eval $v->{source}) {
1253 my $msg = $@ ? "$v->{path}: $@\n"
1254 : "$v->{base}: extension inactive.\n";
1255
1256 if (exists $v->{meta}{mandatory}) {
1257 warn $msg;
1258 warn "mandatory extension failed to load, exiting.\n";
1259 exit 1;
1260 }
1261
1262 warn $msg;
1263 }
1264
1265 $done{$k} = delete $todo{$k};
1266 push @EXTS, $v->{pkg};
1267 $progress = 1;
934 1 1268 }
935 } or warn "$ext not loaded: $@"; 1269
1270 skip:
1271 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1272 unless $progress;
1273 }
936 } 1274 };
937} 1275}
938 1276
939############################################################################# 1277#############################################################################
940 1278
1279=back
1280
941=head2 CORE EXTENSIONS 1281=head2 CORE EXTENSIONS
942 1282
943Functions and methods that extend core crossfire objects. 1283Functions and methods that extend core crossfire objects.
944 1284
945=cut 1285=cut
… …
950 1290
951=head3 cf::player 1291=head3 cf::player
952 1292
953=over 4 1293=over 4
954 1294
1295=item cf::player::num_playing
1296
1297Returns the official number of playing players, as per the Crossfire metaserver rules.
1298
1299=cut
1300
1301sub num_playing {
1302 scalar grep
1303 $_->ob->map
1304 && !$_->hidden
1305 && !$_->ob->flag (cf::FLAG_WIZ),
1306 cf::player::list
1307}
1308
955=item cf::player::find $login 1309=item cf::player::find $login
956 1310
957Returns the given player object, loading it if necessary (might block). 1311Returns the given player object, loading it if necessary (might block).
958 1312
959=cut 1313=cut
960 1314
961sub playerdir($) { 1315sub playerdir($) {
962 cf::localdir 1316 "$PLAYERDIR/"
963 . "/"
964 . cf::playerdir
965 . "/"
966 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1317 . (ref $_[0] ? $_[0]->ob->name : $_[0])
967} 1318}
968 1319
969sub path($) { 1320sub path($) {
970 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1321 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
971 1322
972 (playerdir $login) . "/$login.pl" 1323 (playerdir $login) . "/playerdata"
973} 1324}
974 1325
975sub find_active($) { 1326sub find_active($) {
976 $cf::PLAYER{$_[0]} 1327 $cf::PLAYER{$_[0]}
977 and $cf::PLAYER{$_[0]}->active 1328 and $cf::PLAYER{$_[0]}->active
… …
990 my $login = $_[0]; 1341 my $login = $_[0];
991 1342
992 my $guard = cf::lock_acquire "user_find:$login"; 1343 my $guard = cf::lock_acquire "user_find:$login";
993 1344
994 $cf::PLAYER{$_[0]} || do { 1345 $cf::PLAYER{$_[0]} || do {
995 my $pl = load_pl path $login 1346 # rename old playerfiles to new ones
1347 #TODO: remove when no longer required
1348 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1349 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1350 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1351 aio_unlink +(playerdir $login) . "/$login.pl";
1352
1353 my $f = new_from_file cf::object::thawer path $login
996 or return; 1354 or return;
1355
1356 my $pl = cf::player::load_pl $f
1357 or return;
1358 local $cf::PLAYER_LOADING{$login} = $pl;
1359 $f->resolve_delayed_derefs;
997 $cf::PLAYER{$login} = $pl 1360 $cf::PLAYER{$login} = $pl
998 } 1361 }
999 } 1362 }
1000} 1363}
1001 1364
… …
1011 1374
1012 aio_mkdir playerdir $pl, 0770; 1375 aio_mkdir playerdir $pl, 0770;
1013 $pl->{last_save} = $cf::RUNTIME; 1376 $pl->{last_save} = $cf::RUNTIME;
1014 1377
1015 $pl->save_pl ($path); 1378 $pl->save_pl ($path);
1016 Coro::cede; 1379 cf::cede_to_tick;
1017} 1380}
1018 1381
1019sub new($) { 1382sub new($) {
1020 my ($login) = @_; 1383 my ($login) = @_;
1021 1384
… …
1027 $cf::PLAYER{$login} = $self; 1390 $cf::PLAYER{$login} = $self;
1028 1391
1029 $self 1392 $self
1030} 1393}
1031 1394
1395=item $player->send_msg ($channel, $msg, $color, [extra...])
1396
1397=cut
1398
1399sub send_msg {
1400 my $ns = shift->ns
1401 or return;
1402 $ns->send_msg (@_);
1403}
1404
1032=item $pl->quit_character 1405=item $pl->quit_character
1033 1406
1034Nukes the player without looking back. If logged in, the connection will 1407Nukes the player without looking back. If logged in, the connection will
1035be destroyed. May block for a long time. 1408be destroyed. May block for a long time.
1036 1409
1037=cut 1410=cut
1038 1411
1039sub quit_character { 1412sub quit_character {
1040 my ($pl) = @_; 1413 my ($pl) = @_;
1414
1415 my $name = $pl->ob->name;
1041 1416
1042 $pl->{deny_save} = 1; 1417 $pl->{deny_save} = 1;
1043 $pl->password ("*"); # this should lock out the player until we nuked the dir 1418 $pl->password ("*"); # this should lock out the player until we nuked the dir
1044 1419
1045 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1420 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1050 my $path = playerdir $pl; 1425 my $path = playerdir $pl;
1051 my $temp = "$path~$cf::RUNTIME~deleting~"; 1426 my $temp = "$path~$cf::RUNTIME~deleting~";
1052 aio_rename $path, $temp; 1427 aio_rename $path, $temp;
1053 delete $cf::PLAYER{$pl->ob->name}; 1428 delete $cf::PLAYER{$pl->ob->name};
1054 $pl->destroy; 1429 $pl->destroy;
1430
1431 my $prefix = qr<^~\Q$name\E/>;
1432
1433 # nuke player maps
1434 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1435
1055 IO::AIO::aio_rmtree $temp; 1436 IO::AIO::aio_rmtree $temp;
1437}
1438
1439=item $pl->kick
1440
1441Kicks a player out of the game. This destroys the connection.
1442
1443=cut
1444
1445sub kick {
1446 my ($pl, $kicker) = @_;
1447
1448 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1449 $pl->killer ("kicked");
1450 $pl->ns->destroy;
1056} 1451}
1057 1452
1058=item cf::player::list_logins 1453=item cf::player::list_logins
1059 1454
1060Returns am arrayref of all valid playernames in the system, can take a 1455Returns am arrayref of all valid playernames in the system, can take a
1061while and may block, so not sync_job-capable, ever. 1456while and may block, so not sync_job-capable, ever.
1062 1457
1063=cut 1458=cut
1064 1459
1065sub list_logins { 1460sub list_logins {
1066 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1461 my $dirs = aio_readdir $PLAYERDIR
1067 or return []; 1462 or return [];
1068 1463
1069 my @logins; 1464 my @logins;
1070 1465
1071 for my $login (@$dirs) { 1466 for my $login (@$dirs) {
1467 my $path = path $login;
1468
1469 # a .pst is a dead give-away for a valid player
1470 unless (-e "$path.pst") {
1072 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1471 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1073 aio_read $fh, 0, 512, my $buf, 0 or next; 1472 aio_read $fh, 0, 512, my $buf, 0 or next;
1074 $buf !~ /^password -------------$/m or next; # official not-valid tag 1473 $buf !~ /^password -------------$/m or next; # official not-valid tag
1474 }
1075 1475
1076 utf8::decode $login; 1476 utf8::decode $login;
1077 push @logins, $login; 1477 push @logins, $login;
1078 } 1478 }
1079 1479
… …
1106 } 1506 }
1107 1507
1108 \@paths 1508 \@paths
1109} 1509}
1110 1510
1511=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1512
1513Expand crossfire pod fragments into protocol xml.
1514
1515=cut
1516
1517sub expand_cfpod {
1518 ((my $self), (local $_)) = @_;
1519
1520 # escape & and <
1521 s/&/&amp;/g;
1522 s/(?<![BIUGHT])</&lt;/g;
1523
1524 # this is buggy, it needs to properly take care of nested <'s
1525
1526 1 while
1527 # replace B<>, I<>, U<> etc.
1528 s/B<([^\>]*)>/<b>$1<\/b>/
1529 || s/I<([^\>]*)>/<i>$1<\/i>/
1530 || s/U<([^\>]*)>/<u>$1<\/u>/
1531 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1532 # replace G<male|female> tags
1533 || s{G<([^>|]*)\|([^>]*)>}{
1534 $self->gender ? $2 : $1
1535 }ge
1536 # replace H<hint text>
1537 || s{H<([^\>]*)>}
1538 {
1539 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1540 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1541 "")
1542 [$self->{hintmode}]
1543 }ge;
1544
1545 # create single paragraphs (very hackish)
1546 s/(?<=\S)\n(?=\w)/ /g;
1547
1548 # compress some whitespace
1549 s/\s+\n/\n/g; # ws line-ends
1550 s/\n\n+/\n/g; # double lines
1551 s/^\n+//; # beginning lines
1552 s/\n+$//; # ending lines
1553
1554 $_
1555}
1556
1557sub hintmode {
1558 $_[0]{hintmode} = $_[1] if @_ > 1;
1559 $_[0]{hintmode}
1560}
1561
1111=item $player->ext_reply ($msgid, $msgtype, %msg) 1562=item $player->ext_reply ($msgid, @msg)
1112 1563
1113Sends an ext reply to the player. 1564Sends an ext reply to the player.
1114 1565
1115=cut 1566=cut
1116 1567
1117sub ext_reply($$$%) { 1568sub ext_reply($$@) {
1118 my ($self, $id, %msg) = @_; 1569 my ($self, $id, @msg) = @_;
1119 1570
1120 $msg{msgid} = $id; 1571 $self->ns->ext_reply ($id, @msg)
1121
1122 $self->send ("ext " . cf::to_json \%msg);
1123} 1572}
1124 1573
1125package cf; 1574=item $player->ext_msg ($type, @msg)
1575
1576Sends an ext event to the client.
1577
1578=cut
1579
1580sub ext_msg($$@) {
1581 my ($self, $type, @msg) = @_;
1582
1583 $self->ns->ext_msg ($type, @msg);
1584}
1585
1586=head3 cf::region
1587
1588=over 4
1589
1590=cut
1591
1592package cf::region;
1593
1594=item cf::region::find_by_path $path
1595
1596Tries to decuce the likely region for a map knowing only its path.
1597
1598=cut
1599
1600sub find_by_path($) {
1601 my ($path) = @_;
1602
1603 my ($match, $specificity);
1604
1605 for my $region (list) {
1606 if ($region->{match} && $path =~ $region->{match}) {
1607 ($match, $specificity) = ($region, $region->specificity)
1608 if $region->specificity > $specificity;
1609 }
1610 }
1611
1612 $match
1613}
1126 1614
1127=back 1615=back
1128
1129 1616
1130=head3 cf::map 1617=head3 cf::map
1131 1618
1132=over 4 1619=over 4
1133 1620
… …
1188 my ($self, $merge) = @_; 1675 my ($self, $merge) = @_;
1189 1676
1190 # we have to keep some variables in memory intact 1677 # we have to keep some variables in memory intact
1191 local $self->{path}; 1678 local $self->{path};
1192 local $self->{load_path}; 1679 local $self->{load_path};
1193 local $self->{deny_save};
1194 local $self->{deny_reset};
1195 1680
1196 $self->SUPER::thawer_merge ($merge); 1681 $self->SUPER::thawer_merge ($merge);
1197} 1682}
1198 1683
1199sub normalise { 1684sub normalise {
… …
1246 $self->init; # pass $1 etc. 1731 $self->init; # pass $1 etc.
1247 return $self; 1732 return $self;
1248 } 1733 }
1249 } 1734 }
1250 1735
1251 Carp::carp "unable to resolve path '$path' (base '$base')."; 1736 Carp::cluck "unable to resolve path '$path' (base '$base').";
1252 () 1737 ()
1253} 1738}
1254 1739
1255sub init { 1740sub init {
1256 my ($self) = @_; 1741 my ($self) = @_;
… …
1271 1756
1272# the original (read-only) location 1757# the original (read-only) location
1273sub load_path { 1758sub load_path {
1274 my ($self) = @_; 1759 my ($self) = @_;
1275 1760
1276 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1761 "$MAPDIR/$self->{path}.map"
1277} 1762}
1278 1763
1279# the temporary/swap location 1764# the temporary/swap location
1280sub save_path { 1765sub save_path {
1281 my ($self) = @_; 1766 my ($self) = @_;
1282 1767
1283 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1768 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1284 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1769 "$TMPDIR/$path.map"
1285} 1770}
1286 1771
1287# the unique path, undef == no special unique path 1772# the unique path, undef == no special unique path
1288sub uniq_path { 1773sub uniq_path {
1289 my ($self) = @_; 1774 my ($self) = @_;
1290 1775
1291 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1776 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1292 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1777 "$UNIQUEDIR/$path"
1293} 1778}
1294 1779
1295# and all this just because we cannot iterate over 1780# and all this just because we cannot iterate over
1296# all maps in C++... 1781# all maps in C++...
1297sub change_all_map_light { 1782sub change_all_map_light {
… …
1299 1784
1300 $_->change_map_light ($change) 1785 $_->change_map_light ($change)
1301 for grep $_->outdoor, values %cf::MAP; 1786 for grep $_->outdoor, values %cf::MAP;
1302} 1787}
1303 1788
1789sub decay_objects {
1790 my ($self) = @_;
1791
1792 return if $self->{deny_reset};
1793
1794 $self->do_decay_objects;
1795}
1796
1304sub unlink_save { 1797sub unlink_save {
1305 my ($self) = @_; 1798 my ($self) = @_;
1306 1799
1307 utf8::encode (my $save = $self->save_path); 1800 utf8::encode (my $save = $self->save_path);
1308 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1801 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1309 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst"; 1802 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1310
1311 #d#TODO remove .map and also nuke
1312 $save =~ s/\.map// or return;#d#
1313 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;#d#
1314 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";#d#
1315} 1803}
1316 1804
1317sub load_header_from($) { 1805sub load_header_from($) {
1318 my ($self, $path) = @_; 1806 my ($self, $path) = @_;
1319 1807
1320 utf8::encode $path; 1808 utf8::encode $path;
1321 #aio_open $path, O_RDONLY, 0 1809 my $f = new_from_file cf::object::thawer $path
1322 # or return;
1323
1324 $self->_load_header ($path)
1325 or return; 1810 or return;
1811
1812 $self->_load_header ($f)
1813 or return;
1814
1815 local $MAP_LOADING{$self->{path}} = $self;
1816 $f->resolve_delayed_derefs;
1326 1817
1327 $self->{load_path} = $path; 1818 $self->{load_path} = $path;
1328 1819
1329 1 1820 1
1330} 1821}
… …
1369 $self->load_header_orig 1860 $self->load_header_orig
1370 or return; 1861 or return;
1371 $self->prepare_orig; 1862 $self->prepare_orig;
1372 } 1863 }
1373 1864
1865 $self->{deny_reset} = 1
1866 if $self->no_reset;
1867
1868 $self->default_region (cf::region::find_by_path $self->{path})
1869 unless $self->default_region;
1870
1374 1 1871 1
1375} 1872}
1376 1873
1377sub find; 1874sub find;
1378sub find { 1875sub find {
1379 my ($path, $origin) = @_; 1876 my ($path, $origin) = @_;
1380 1877
1381 $path = normalise $path, $origin && $origin->path; 1878 $path = normalise $path, $origin && $origin->path;
1382 1879
1880 cf::lock_wait "map_data:$path";#d#remove
1383 cf::lock_wait "map_find:$path"; 1881 cf::lock_wait "map_find:$path";
1384 1882
1385 $cf::MAP{$path} || do { 1883 $cf::MAP{$path} || do {
1386 my $guard = cf::lock_acquire "map_find:$path"; 1884 my $guard1 = cf::lock_acquire "map_find:$path";
1885 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1886
1387 my $map = new_from_path cf::map $path 1887 my $map = new_from_path cf::map $path
1388 or return; 1888 or return;
1389 1889
1390 $map->{last_save} = $cf::RUNTIME; 1890 $map->{last_save} = $cf::RUNTIME;
1391 1891
1392 $map->load_header 1892 $map->load_header
1393 or return; 1893 or return;
1394 1894
1395 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1895 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1396 # doing this can freeze the server in a sync job, obviously 1896 # doing this can freeze the server in a sync job, obviously
1397 #$cf::WAIT_FOR_TICK->wait; 1897 #$cf::WAIT_FOR_TICK->wait;
1898 undef $guard1;
1899 undef $guard2;
1398 $map->reset; 1900 $map->reset;
1399 undef $guard;
1400 return find $path; 1901 return find $path;
1401 } 1902 }
1402 1903
1403 $cf::MAP{$path} = $map 1904 $cf::MAP{$path} = $map
1404 } 1905 }
… …
1411 my ($self) = @_; 1912 my ($self) = @_;
1412 1913
1413 local $self->{deny_reset} = 1; # loading can take a long time 1914 local $self->{deny_reset} = 1; # loading can take a long time
1414 1915
1415 my $path = $self->{path}; 1916 my $path = $self->{path};
1917
1918 {
1416 my $guard = cf::lock_acquire "map_load:$path"; 1919 my $guard = cf::lock_acquire "map_data:$path";
1417 1920
1921 return unless $self->valid;
1418 return if $self->in_memory != cf::MAP_SWAPPED; 1922 return unless $self->in_memory == cf::MAP_SWAPPED;
1419 1923
1420 $self->in_memory (cf::MAP_LOADING); 1924 $self->in_memory (cf::MAP_LOADING);
1421 1925
1422 $self->alloc; 1926 $self->alloc;
1423 1927
1424 $self->pre_load; 1928 $self->pre_load;
1929 cf::cede_to_tick;
1425 1930
1426 $self->_load_objects ($self->{load_path}, 1) 1931 my $f = new_from_file cf::object::thawer $self->{load_path};
1932 $f->skip_block;
1933 $self->_load_objects ($f)
1427 or return; 1934 or return;
1428 1935
1429 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1936 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1430 if delete $self->{load_original}; 1937 if delete $self->{load_original};
1431 1938
1432 if (my $uniq = $self->uniq_path) { 1939 if (my $uniq = $self->uniq_path) {
1433 utf8::encode $uniq; 1940 utf8::encode $uniq;
1434 if (aio_open $uniq, O_RDONLY, 0) { 1941 unless (aio_stat $uniq) {
1942 if (my $f = new_from_file cf::object::thawer $uniq) {
1435 $self->clear_unique_items; 1943 $self->clear_unique_items;
1436 $self->_load_objects ($uniq, 0); 1944 $self->_load_objects ($f);
1945 $f->resolve_delayed_derefs;
1946 }
1437 } 1947 }
1438 } 1948 }
1439 1949
1440 Coro::cede; 1950 $f->resolve_delayed_derefs;
1441 1951
1952 cf::cede_to_tick;
1442 # now do the right thing for maps 1953 # now do the right thing for maps
1443 $self->link_multipart_objects; 1954 $self->link_multipart_objects;
1444
1445 unless ($self->{deny_activate}) {
1446 $self->decay_objects;
1447 $self->fix_auto_apply;
1448 $self->update_buttons;
1449 Coro::cede;
1450 $self->set_darkness_map;
1451 $self->difficulty ($self->estimate_difficulty) 1955 $self->difficulty ($self->estimate_difficulty)
1452 unless $self->difficulty; 1956 unless $self->difficulty;
1453 Coro::cede; 1957 cf::cede_to_tick;
1958
1959 unless ($self->{deny_activate}) {
1960 $self->decay_objects;
1961 $self->fix_auto_apply;
1962 $self->update_buttons;
1963 cf::cede_to_tick;
1964 $self->set_darkness_map;
1965 cf::cede_to_tick;
1454 $self->activate; 1966 $self->activate;
1967 }
1968
1969 $self->{last_save} = $cf::RUNTIME;
1970 $self->last_access ($cf::RUNTIME);
1971
1972 $self->in_memory (cf::MAP_IN_MEMORY);
1455 } 1973 }
1456 1974
1457 $self->post_load; 1975 $self->post_load;
1458
1459 $self->in_memory (cf::MAP_IN_MEMORY);
1460} 1976}
1461 1977
1462sub customise_for { 1978sub customise_for {
1463 my ($self, $ob) = @_; 1979 my ($self, $ob) = @_;
1464 1980
1465 return find "~" . $ob->name . "/" . $self->{path} 1981 return find "~" . $ob->name . "/" . $self->{path}
1466 if $self->per_player; 1982 if $self->per_player;
1467 1983
1984# return find "?party/" . $ob->name . "/" . $self->{path}
1985# if $self->per_party;
1986
1468 $self 1987 $self
1469} 1988}
1470 1989
1471# find and load all maps in the 3x3 area around a map 1990# find and load all maps in the 3x3 area around a map
1472sub load_diag { 1991sub load_neighbours {
1473 my ($map) = @_; 1992 my ($map) = @_;
1474 1993
1475 my @diag; # diagonal neighbours 1994 my @neigh; # diagonal neighbours
1476 1995
1477 for (0 .. 3) { 1996 for (0 .. 3) {
1478 my $neigh = $map->tile_path ($_) 1997 my $neigh = $map->tile_path ($_)
1479 or next; 1998 or next;
1480 $neigh = find $neigh, $map 1999 $neigh = find $neigh, $map
1481 or next; 2000 or next;
1482 $neigh->load; 2001 $neigh->load;
1483 2002
2003 push @neigh,
1484 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2004 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1485 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2005 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1486 } 2006 }
1487 2007
1488 for (@diag) { 2008 for (grep defined $_->[0], @neigh) {
2009 my ($path, $origin) = @$_;
1489 my $neigh = find @$_ 2010 my $neigh = find $path, $origin
1490 or next; 2011 or next;
1491 $neigh->load; 2012 $neigh->load;
1492 } 2013 }
1493} 2014}
1494 2015
… …
1499} 2020}
1500 2021
1501sub do_load_sync { 2022sub do_load_sync {
1502 my ($map) = @_; 2023 my ($map) = @_;
1503 2024
2025 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2026 if $Coro::current == $Coro::main;
2027
1504 cf::sync_job { $map->load }; 2028 cf::sync_job { $map->load };
1505} 2029}
1506 2030
1507our %MAP_PREFETCH; 2031our %MAP_PREFETCH;
1508our $MAP_PREFETCHER = undef; 2032our $MAP_PREFETCHER = undef;
1509 2033
1510sub find_async { 2034sub find_async {
1511 my ($path, $origin) = @_; 2035 my ($path, $origin, $load) = @_;
1512 2036
1513 $path = normalise $path, $origin && $origin->{path}; 2037 $path = normalise $path, $origin && $origin->{path};
1514 2038
1515 if (my $map = $cf::MAP{$path}) { 2039 if (my $map = $cf::MAP{$path}) {
1516 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2040 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1517 } 2041 }
1518 2042
1519 undef $MAP_PREFETCH{$path}; 2043 $MAP_PREFETCH{$path} |= $load;
2044
1520 $MAP_PREFETCHER ||= cf::async { 2045 $MAP_PREFETCHER ||= cf::async {
2046 $Coro::current->{desc} = "map prefetcher";
2047
1521 while (%MAP_PREFETCH) { 2048 while (%MAP_PREFETCH) {
1522 for my $path (keys %MAP_PREFETCH) { 2049 while (my ($k, $v) = each %MAP_PREFETCH) {
1523 my $map = find $path 2050 if (my $map = find $k) {
1524 or next;
1525 $map->load; 2051 $map->load if $v;
2052 }
1526 2053
1527 delete $MAP_PREFETCH{$path}; 2054 delete $MAP_PREFETCH{$k};
1528 } 2055 }
1529 } 2056 }
1530 undef $MAP_PREFETCHER; 2057 undef $MAP_PREFETCHER;
1531 }; 2058 };
1532 $MAP_PREFETCHER->prio (6); 2059 $MAP_PREFETCHER->prio (6);
… …
1535} 2062}
1536 2063
1537sub save { 2064sub save {
1538 my ($self) = @_; 2065 my ($self) = @_;
1539 2066
1540 my $lock = cf::lock_acquire "map_data:" . $self->path; 2067 my $lock = cf::lock_acquire "map_data:$self->{path}";
1541 2068
1542 $self->{last_save} = $cf::RUNTIME; 2069 $self->{last_save} = $cf::RUNTIME;
1543 2070
1544 return unless $self->dirty; 2071 return unless $self->dirty;
1545 2072
… …
1551 return if $self->{deny_save}; 2078 return if $self->{deny_save};
1552 2079
1553 local $self->{last_access} = $self->last_access;#d# 2080 local $self->{last_access} = $self->last_access;#d#
1554 2081
1555 cf::async { 2082 cf::async {
2083 $Coro::current->{desc} = "map player save";
1556 $_->contr->save for $self->players; 2084 $_->contr->save for $self->players;
1557 }; 2085 };
1558 2086
1559 if ($uniq) { 2087 if ($uniq) {
1560 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2088 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1568 my ($self) = @_; 2096 my ($self) = @_;
1569 2097
1570 # save first because save cedes 2098 # save first because save cedes
1571 $self->save; 2099 $self->save;
1572 2100
1573 my $lock = cf::lock_acquire "map_data:" . $self->path; 2101 my $lock = cf::lock_acquire "map_data:$self->{path}";
1574 2102
1575 return if $self->players; 2103 return if $self->players;
1576 return if $self->in_memory != cf::MAP_IN_MEMORY; 2104 return if $self->in_memory != cf::MAP_IN_MEMORY;
1577 return if $self->{deny_save}; 2105 return if $self->{deny_save};
1578 2106
2107 $self->in_memory (cf::MAP_SWAPPED);
2108
2109 $self->deactivate;
2110 $_->clear_links_to ($self) for values %cf::MAP;
1579 $self->clear; 2111 $self->clear;
1580 $self->in_memory (cf::MAP_SWAPPED);
1581} 2112}
1582 2113
1583sub reset_at { 2114sub reset_at {
1584 my ($self) = @_; 2115 my ($self) = @_;
1585 2116
1586 # TODO: safety, remove and allow resettable per-player maps 2117 # TODO: safety, remove and allow resettable per-player maps
1587 return 1e99 if $self->isa ("ext::map_per_player");#d#
1588 return 1e99 if $self->{deny_reset}; 2118 return 1e99 if $self->{deny_reset};
1589 2119
1590 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2120 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1591 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2121 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1592 2122
… …
1603 my ($self) = @_; 2133 my ($self) = @_;
1604 2134
1605 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2135 my $lock = cf::lock_acquire "map_data:$self->{path}";
1606 2136
1607 return if $self->players; 2137 return if $self->players;
1608 return if $self->isa ("ext::map_per_player");#d#
1609 2138
1610 warn "resetting map ", $self->path;#d# 2139 warn "resetting map ", $self->path;
1611 2140
1612 $self->in_memory (cf::MAP_SWAPPED); 2141 $self->in_memory (cf::MAP_SWAPPED);
1613 2142
1614 # need to save uniques path 2143 # need to save uniques path
1615 unless ($self->{deny_save}) { 2144 unless ($self->{deny_save}) {
… …
1619 if $uniq; 2148 if $uniq;
1620 } 2149 }
1621 2150
1622 delete $cf::MAP{$self->path}; 2151 delete $cf::MAP{$self->path};
1623 2152
2153 $self->deactivate;
2154 $_->clear_links_to ($self) for values %cf::MAP;
1624 $self->clear; 2155 $self->clear;
1625
1626 $_->clear_links_to ($self) for values %cf::MAP;
1627 2156
1628 $self->unlink_save; 2157 $self->unlink_save;
1629 $self->destroy; 2158 $self->destroy;
1630} 2159}
1631 2160
1632my $nuke_counter = "aaaa"; 2161my $nuke_counter = "aaaa";
1633 2162
1634sub nuke { 2163sub nuke {
1635 my ($self) = @_; 2164 my ($self) = @_;
1636 2165
2166 {
2167 my $lock = cf::lock_acquire "map_data:$self->{path}";
2168
1637 delete $cf::MAP{$self->path}; 2169 delete $cf::MAP{$self->path};
1638 2170
1639 $self->unlink_save; 2171 $self->unlink_save;
1640 2172
1641 bless $self, "cf::map"; 2173 bless $self, "cf::map";
1642 delete $self->{deny_reset}; 2174 delete $self->{deny_reset};
1643 $self->{deny_save} = 1; 2175 $self->{deny_save} = 1;
1644 $self->reset_timeout (1); 2176 $self->reset_timeout (1);
1645 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2177 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1646 2178
1647 $cf::MAP{$self->path} = $self; 2179 $cf::MAP{$self->path} = $self;
2180 }
1648 2181
1649 $self->reset; # polite request, might not happen 2182 $self->reset; # polite request, might not happen
2183}
2184
2185=item $maps = cf::map::tmp_maps
2186
2187Returns an arrayref with all map paths of currently instantiated and saved
2188maps. May block.
2189
2190=cut
2191
2192sub tmp_maps() {
2193 [
2194 map {
2195 utf8::decode $_;
2196 /\.map$/
2197 ? normalise $_
2198 : ()
2199 } @{ aio_readdir $TMPDIR or [] }
2200 ]
2201}
2202
2203=item $maps = cf::map::random_maps
2204
2205Returns an arrayref with all map paths of currently instantiated and saved
2206random maps. May block.
2207
2208=cut
2209
2210sub random_maps() {
2211 [
2212 map {
2213 utf8::decode $_;
2214 /\.map$/
2215 ? normalise "?random/$_"
2216 : ()
2217 } @{ aio_readdir $RANDOMDIR or [] }
2218 ]
1650} 2219}
1651 2220
1652=item cf::map::unique_maps 2221=item cf::map::unique_maps
1653 2222
1654Returns an arrayref of paths of all shared maps that have 2223Returns an arrayref of paths of all shared maps that have
1655instantiated unique items. May block. 2224instantiated unique items. May block.
1656 2225
1657=cut 2226=cut
1658 2227
1659sub unique_maps() { 2228sub unique_maps() {
1660 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2229 [
1661 or return; 2230 map {
1662
1663 my @paths;
1664
1665 for (@$files) {
1666 utf8::decode $_; 2231 utf8::decode $_;
1667 next if /\.pst$/; 2232 /\.map$/
1668 next unless /^$PATH_SEP/o; 2233 ? normalise $_
1669 2234 : ()
1670 push @paths, cf::map::normalise $_; 2235 } @{ aio_readdir $UNIQUEDIR or [] }
1671 } 2236 ]
1672
1673 \@paths
1674} 2237}
1675 2238
1676package cf; 2239package cf;
1677 2240
1678=back 2241=back
… …
1696 map { $_, inv_recursive_ $_->inv } @_ 2259 map { $_, inv_recursive_ $_->inv } @_
1697} 2260}
1698 2261
1699sub inv_recursive { 2262sub inv_recursive {
1700 inv_recursive_ inv $_[0] 2263 inv_recursive_ inv $_[0]
2264}
2265
2266=item $ref = $ob->ref
2267
2268creates and returns a persistent reference to an objetc that can be stored as a string.
2269
2270=item $ob = cf::object::deref ($refstring)
2271
2272returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2273even if the object actually exists. May block.
2274
2275=cut
2276
2277sub deref {
2278 my ($ref) = @_;
2279
2280 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2281 my ($uuid, $name) = ($1, $2);
2282 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2283 or return;
2284 $pl->ob->uuid eq $uuid
2285 or return;
2286
2287 $pl->ob
2288 } else {
2289 warn "$ref: cannot resolve object reference\n";
2290 undef
2291 }
1701} 2292}
1702 2293
1703package cf; 2294package cf;
1704 2295
1705=back 2296=back
… …
1724 2315
1725 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2316 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1726 2317
1727 if ($self->{record_replies}) { 2318 if ($self->{record_replies}) {
1728 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2319 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2320
1729 } else { 2321 } else {
2322 my $pl = $self->contr;
2323
2324 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2325 my $dialog = $pl->{npc_dialog};
2326 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2327
2328 } else {
1730 $msg = $npc->name . " says: $msg" if $npc; 2329 $msg = $npc->name . " says: $msg" if $npc;
1731 $self->message ($msg, $flags); 2330 $self->message ($msg, $flags);
2331 }
1732 } 2332 }
2333}
2334
2335=item $object->send_msg ($channel, $msg, $color, [extra...])
2336
2337=cut
2338
2339sub cf::object::send_msg {
2340 my $pl = shift->contr
2341 or return;
2342 $pl->send_msg (@_);
1733} 2343}
1734 2344
1735=item $player_object->may ("access") 2345=item $player_object->may ("access")
1736 2346
1737Returns wether the given player is authorized to access resource "access" 2347Returns wether the given player is authorized to access resource "access"
… …
1784 $self->deactivate_recursive; 2394 $self->deactivate_recursive;
1785 2395
1786 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2396 return if UNIVERSAL::isa $self->map, "ext::map_link";
1787 2397
1788 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2398 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1789 if $self->map; 2399 if $self->map && $self->map->{path} ne "{link}";
1790 2400
1791 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2401 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1792} 2402}
1793 2403
1794sub cf::object::player::leave_link { 2404sub cf::object::player::leave_link {
1795 my ($self, $map, $x, $y) = @_; 2405 my ($self, $map, $x, $y) = @_;
2406
2407 return unless $self->contr->active;
1796 2408
1797 my $link_pos = delete $self->{_link_pos}; 2409 my $link_pos = delete $self->{_link_pos};
1798 2410
1799 unless ($map) { 2411 unless ($map) {
1800 # restore original map position 2412 # restore original map position
… …
1814 # use -1 or undef as default coordinates, not 0, 0 2426 # use -1 or undef as default coordinates, not 0, 0
1815 ($x, $y) = ($map->enter_x, $map->enter_y) 2427 ($x, $y) = ($map->enter_x, $map->enter_y)
1816 if $x <=0 && $y <= 0; 2428 if $x <=0 && $y <= 0;
1817 2429
1818 $map->load; 2430 $map->load;
1819 $map->load_diag; 2431 $map->load_neighbours;
1820 2432
1821 return unless $self->contr->active; 2433 return unless $self->contr->active;
1822 $self->activate_recursive; 2434 $self->activate_recursive;
1823 2435
1824 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2436 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1825 $self->enter_map ($map, $x, $y); 2437 $self->enter_map ($map, $x, $y);
1826} 2438}
1827 2439
1828cf::player->attach ( 2440=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1829 on_logout => sub {
1830 my ($pl) = @_;
1831 2441
1832 # abort map switching before logout 2442Moves the player to the given map-path and coordinates by first freezing
1833 if ($pl->ob->{_link_pos}) { 2443her, loading and preparing them map, calling the provided $check callback
1834 cf::sync_job { 2444that has to return the map if sucecssful, and then unfreezes the player on
1835 $pl->ob->leave_link 2445the new (success) or old (failed) map position. In either case, $done will
1836 }; 2446be called at the end of this process.
1837 }
1838 },
1839 on_login => sub {
1840 my ($pl) = @_;
1841 2447
1842 # try to abort aborted map switching on player login :)
1843 # should happen only on crashes
1844 if ($pl->ob->{_link_pos}) {
1845 $pl->ob->enter_link;
1846 (async {
1847 $pl->ob->reply (undef,
1848 "There was an internal problem at your last logout, "
1849 . "the server will try to bring you to your intended destination in a second.",
1850 cf::NDI_RED);
1851 # we need this sleep as the login has a concurrent enter_exit running
1852 # and this sleep increases chances of the player not ending up in scorn
1853 Coro::Timer::sleep 1;
1854 $pl->ob->leave_link;
1855 })->prio (2);
1856 }
1857 },
1858);
1859
1860=item $player_object->goto ($path, $x, $y)
1861
1862=cut 2448=cut
2449
2450our $GOTOGEN;
1863 2451
1864sub cf::object::player::goto { 2452sub cf::object::player::goto {
1865 my ($self, $path, $x, $y) = @_; 2453 my ($self, $path, $x, $y, $check, $done) = @_;
2454
2455 # do generation counting so two concurrent goto's will be executed in-order
2456 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1866 2457
1867 $self->enter_link; 2458 $self->enter_link;
1868 2459
1869 (async { 2460 (async {
2461 $Coro::current->{desc} = "player::goto $path $x $y";
2462
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
1870 my $map = eval { 2482 my $map = eval {
1871 my $map = cf::map::find $path; 2483 my $map = defined $path ? cf::map::find $path : undef;
2484
2485 if ($map) {
1872 $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
1873 $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 $@;
1874 } or 2498 }
1875 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1876 2499
2500 if ($gen == $self->{_goto_generation}) {
2501 delete $self->{_goto_generation};
1877 $self->leave_link ($map, $x, $y); 2502 $self->leave_link ($map, $x, $y);
2503 }
2504
2505 $done->() if $done;
1878 })->prio (1); 2506 })->prio (1);
1879} 2507}
1880 2508
1881=item $player_object->enter_exit ($exit_object) 2509=item $player_object->enter_exit ($exit_object)
1882 2510
… …
1921 2549
1922 $rmp->{random_seed} ||= $exit->random_seed; 2550 $rmp->{random_seed} ||= $exit->random_seed;
1923 2551
1924 my $data = cf::to_json $rmp; 2552 my $data = cf::to_json $rmp;
1925 my $md5 = Digest::MD5::md5_hex $data; 2553 my $md5 = Digest::MD5::md5_hex $data;
1926 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2554 my $meta = "$RANDOMDIR/$md5.meta";
1927 2555
1928 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2556 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1929 aio_write $fh, 0, (length $data), $data, 0; 2557 aio_write $fh, 0, (length $data), $data, 0;
1930 undef $fh; 2558 undef $fh;
1931 aio_rename "$meta~", $meta; 2559 aio_rename "$meta~", $meta;
… …
1940 2568
1941 return unless $self->type == cf::PLAYER; 2569 return unless $self->type == cf::PLAYER;
1942 2570
1943 if ($exit->slaying eq "/!") { 2571 if ($exit->slaying eq "/!") {
1944 #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
1945 cf::sync_job { prepare_random_map $exit }; 2575 cf::sync_job { prepare_random_map $exit };
1946 } 2576 }
1947 2577
1948 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;
1949 my $hp = $exit->stats->hp; 2579 my $hp = $exit->stats->hp;
1950 my $sp = $exit->stats->sp; 2580 my $sp = $exit->stats->sp;
1951 2581
1952 $self->enter_link; 2582 $self->enter_link;
1953 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);
2587
1954 (async { 2588 (async {
2589 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2590
1955 $self->deactivate_recursive; # just to be sure 2591 $self->deactivate_recursive; # just to be sure
1956 unless (eval { 2592 unless (eval {
1957 $self->goto ($slaying, $hp, $sp); 2593 $self->goto ($slaying, $hp, $sp);
1958 2594
1959 1; 2595 1;
1960 }) { 2596 }) {
1961 $self->message ("Something went wrong deep within the crossfire server. " 2597 $self->message ("Something went wrong deep within the crossfire server. "
1962 . "I'll try to bring you back to the map you were before. " 2598 . "I'll try to bring you back to the map you were before. "
1963 . "Please report this to the dungeon master!", 2599 . "Please report this to the dungeon master!",
1964 cf::NDI_UNIQUE | cf::NDI_RED); 2600 cf::NDI_UNIQUE | cf::NDI_RED);
1965 2601
1966 warn "ERROR in enter_exit: $@"; 2602 warn "ERROR in enter_exit: $@";
1967 $self->leave_link; 2603 $self->leave_link;
1968 } 2604 }
1969 })->prio (1); 2605 })->prio (1);
… …
1982 2618
1983sub cf::client::send_drawinfo { 2619sub cf::client::send_drawinfo {
1984 my ($self, $text, $flags) = @_; 2620 my ($self, $text, $flags) = @_;
1985 2621
1986 utf8::encode $text; 2622 utf8::encode $text;
1987 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2623 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1988} 2624}
1989 2625
2626=item $client->send_msg ($channel, $msg, $color, [extra...])
2627
2628Send a drawinfo or msg packet to the client, formatting the msg for the
2629client if neccessary. C<$type> should be a string identifying the type of
2630the message, with C<log> being the default. If C<$color> is negative, suppress
2631the message unless the client supports the msg packet.
2632
2633=cut
2634
2635our %CHANNEL = (
2636 "c/identify" => {
2637 id => "infobox",
2638 title => "Identify",
2639 reply => undef,
2640 tooltip => "Items recently identified",
2641 },
2642 "c/examine" => {
2643 id => "infobox",
2644 title => "Examine",
2645 reply => undef,
2646 tooltip => "Signs and other items you examined",
2647 },
2648 "c/lookat" => {
2649 id => "infobox",
2650 title => "Look",
2651 reply => undef,
2652 tooltip => "What you saw there",
2653 },
2654);
2655
2656sub cf::client::send_msg {
2657 my ($self, $channel, $msg, $color, @extra) = @_;
2658
2659 $msg = $self->pl->expand_cfpod ($msg);
2660
2661 $color &= cf::NDI_CLIENT_MASK; # just in case...
2662
2663 # check predefined channels, for the benefit of C
2664 if ($CHANNEL{$channel}) {
2665 $channel = $CHANNEL{$channel};
2666
2667 $self->ext_msg (channel_info => $channel)
2668 if $self->can_msg;
2669
2670 $channel = $channel->{id};
2671
2672 } elsif (ref $channel) {
2673 # send meta info to client, if not yet sent
2674 unless (exists $self->{channel}{$channel->{id}}) {
2675 $self->{channel}{$channel->{id}} = $channel;
2676 $self->ext_msg (channel_info => $channel)
2677 if $self->can_msg;
2678 }
2679
2680 $channel = $channel->{id};
2681 }
2682
2683 return unless @extra || length $msg;
2684
2685 if ($self->can_msg) {
2686 # default colour, mask it out
2687 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2688 if $color & cf::NDI_DEF;
2689
2690 $self->send_packet ("msg " . $self->{json_coder}->encode (
2691 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2692 } else {
2693 if ($color >= 0) {
2694 # replace some tags by gcfclient-compatible ones
2695 for ($msg) {
2696 1 while
2697 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2698 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2699 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2700 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2701 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2702 }
2703
2704 $color &= cf::NDI_COLOR_MASK;
2705
2706 utf8::encode $msg;
2707
2708 if (0 && $msg =~ /\[/) {
2709 # COMMAND/INFO
2710 $self->send_packet ("drawextinfo $color 10 8 $msg")
2711 } else {
2712 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2713 $self->send_packet ("drawinfo $color $msg")
2714 }
2715 }
2716 }
2717}
2718
2719=item $client->ext_msg ($type, @msg)
2720
2721Sends an ext event to the client.
2722
2723=cut
2724
2725sub cf::client::ext_msg($$@) {
2726 my ($self, $type, @msg) = @_;
2727
2728 if ($self->extcmd == 2) {
2729 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2730 } elsif ($self->extcmd == 1) { # TODO: remove
2731 push @msg, msgtype => "event_$type";
2732 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2733 }
2734}
2735
2736=item $client->ext_reply ($msgid, @msg)
2737
2738Sends an ext reply to the client.
2739
2740=cut
2741
2742sub cf::client::ext_reply($$@) {
2743 my ($self, $id, @msg) = @_;
2744
2745 if ($self->extcmd == 2) {
2746 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2747 } elsif ($self->extcmd == 1) {
2748 #TODO: version 1, remove
2749 unshift @msg, msgtype => "reply", msgid => $id;
2750 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2751 }
2752}
1990 2753
1991=item $success = $client->query ($flags, "text", \&cb) 2754=item $success = $client->query ($flags, "text", \&cb)
1992 2755
1993Queues a query to the client, calling the given callback with 2756Queues a query to the client, calling the given callback with
1994the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2757the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1995C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2758C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1996 2759
1997Queries can fail, so check the return code. Or don't, as queries will become 2760Queries can fail, so check the return code. Or don't, as queries will
1998reliable at some point in the future. 2761become reliable at some point in the future.
1999 2762
2000=cut 2763=cut
2001 2764
2002sub cf::client::query { 2765sub cf::client::query {
2003 my ($self, $flags, $text, $cb) = @_; 2766 my ($self, $flags, $text, $cb) = @_;
… …
2011 utf8::encode $text; 2774 utf8::encode $text;
2012 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2775 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2013 2776
2014 $self->send_packet ($self->{query_queue}[0][0]) 2777 $self->send_packet ($self->{query_queue}[0][0])
2015 if @{ $self->{query_queue} } == 1; 2778 if @{ $self->{query_queue} } == 1;
2779
2780 1
2016} 2781}
2017 2782
2018cf::client->attach ( 2783cf::client->attach (
2784 on_connect => sub {
2785 my ($ns) = @_;
2786
2787 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2788 },
2019 on_reply => sub { 2789 on_reply => sub {
2020 my ($ns, $msg) = @_; 2790 my ($ns, $msg) = @_;
2021 2791
2022 # this weird shuffling is so that direct followup queries 2792 # this weird shuffling is so that direct followup queries
2023 # get handled first 2793 # get handled first
… …
2035 } else { 2805 } else {
2036 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2806 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2037 } 2807 }
2038 } 2808 }
2039 }, 2809 },
2810 on_exticmd => sub {
2811 my ($ns, $buf) = @_;
2812
2813 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2814
2815 if (ref $msg) {
2816 my ($type, $reply, @payload) =
2817 "ARRAY" eq ref $msg
2818 ? @$msg
2819 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2820
2821 my @reply;
2822
2823 if (my $cb = $EXTICMD{$type}) {
2824 @reply = $cb->($ns, @payload);
2825 }
2826
2827 $ns->ext_reply ($reply, @reply)
2828 if $reply;
2829
2830 } else {
2831 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2832 }
2833
2834 cf::override;
2835 },
2040); 2836);
2041 2837
2042=item $client->async (\&cb) 2838=item $client->async (\&cb)
2043 2839
2044Create a new coroutine, running the specified callback. The coroutine will 2840Create a new coroutine, running the specified callback. The coroutine will
… …
2085our $safe = new Safe "safe"; 2881our $safe = new Safe "safe";
2086our $safe_hole = new Safe::Hole; 2882our $safe_hole = new Safe::Hole;
2087 2883
2088$SIG{FPE} = 'IGNORE'; 2884$SIG{FPE} = 'IGNORE';
2089 2885
2090$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2886$safe->permit_only (Opcode::opset qw(
2887 :base_core :base_mem :base_orig :base_math
2888 grepstart grepwhile mapstart mapwhile
2889 sort time
2890));
2091 2891
2092# here we export the classes and methods available to script code 2892# here we export the classes and methods available to script code
2093 2893
2094=pod 2894=pod
2095 2895
2096The following fucntions and emthods are available within a safe environment: 2896The following functions and methods are available within a safe environment:
2097 2897
2098 cf::object contr pay_amount pay_player map 2898 cf::object
2899 contr pay_amount pay_player map x y force_find force_add
2900 insert remove name archname title slaying race decrease_ob_nr
2901
2099 cf::object::player player 2902 cf::object::player
2100 cf::player peaceful 2903 player
2101 cf::map trigger 2904
2905 cf::player
2906 peaceful
2907
2908 cf::map
2909 trigger
2102 2910
2103=cut 2911=cut
2104 2912
2105for ( 2913for (
2106 ["cf::object" => qw(contr pay_amount pay_player map)], 2914 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2915 insert remove inv name archname title slaying race
2916 decrease_ob_nr)],
2107 ["cf::object::player" => qw(player)], 2917 ["cf::object::player" => qw(player)],
2108 ["cf::player" => qw(peaceful)], 2918 ["cf::player" => qw(peaceful)],
2109 ["cf::map" => qw(trigger)], 2919 ["cf::map" => qw(trigger)],
2110) { 2920) {
2111 no strict 'refs'; 2921 no strict 'refs';
… …
2182=back 2992=back
2183 2993
2184=cut 2994=cut
2185 2995
2186############################################################################# 2996#############################################################################
2187
2188=head2 EXTENSION DATABASE SUPPORT
2189
2190Crossfire maintains a very simple database for extension use. It can
2191currently store anything that can be serialised using Storable, which
2192excludes objects.
2193
2194The parameter C<$family> should best start with the name of the extension
2195using it, it should be unique.
2196
2197=over 4
2198
2199=item $value = cf::db_get $family => $key
2200
2201Returns a single value from the database.
2202
2203=item cf::db_put $family => $key => $value
2204
2205Stores the given C<$value> in the family.
2206
2207=cut
2208
2209our $DB;
2210
2211sub db_init {
2212 unless ($DB) {
2213 $DB = BDB::db_create $DB_ENV;
2214
2215 cf::sync_job {
2216 eval {
2217 $DB->set_flags (BDB::CHKSUM);
2218
2219 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2220 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2221 cf::cleanup "db_open(db): $!" if $!;
2222 };
2223 cf::cleanup "db_open(db): $@" if $@;
2224 };
2225
2226 my $path = cf::localdir . "/database.pst";
2227 if (stat $path) {
2228 cf::sync_job {
2229 my $pst = Storable::retrieve $path;
2230
2231 cf::db_put (board => data => $pst->{board});
2232 cf::db_put (guildrules => data => $pst->{guildrules});
2233 cf::db_put (rent => balance => $pst->{rent}{balance});
2234 BDB::db_env_txn_checkpoint $DB_ENV;
2235
2236 unlink $path;
2237 };
2238 }
2239 }
2240}
2241
2242sub db_get($$) {
2243 my $key = "$_[0]/$_[1]";
2244
2245 cf::sync_job {
2246 BDB::db_get $DB, undef, $key, my $data;
2247
2248 $! ? ()
2249 : Compress::LZF::sthaw $data
2250 }
2251}
2252
2253sub db_put($$$) {
2254 BDB::dbreq_pri 4;
2255 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2256}
2257
2258#############################################################################
2259# the server's init and main functions 2997# the server's init and main functions
2260 2998
2261sub load_resources { 2999sub load_facedata($) {
2262 load_regions sprintf "%s/%s/regions", cf::datadir, cf::mapdir 3000 my ($path) = @_;
3001
3002 # HACK to clear player env face cache, we need some signal framework
3003 # for this (global event?)
3004 %ext::player_env::MUSIC_FACE_CACHE = ();
3005
3006 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3007
3008 warn "loading facedata from $path\n";
3009
3010 my $facedata;
3011 0 < aio_load $path, $facedata
3012 or die "$path: $!";
3013
3014 $facedata = Coro::Storable::thaw $facedata;
3015
3016 $facedata->{version} == 2
3017 or cf::cleanup "$path: version mismatch, cannot proceed.";
3018
3019 # patch in the exptable
3020 $facedata->{resource}{"res/exp_table"} = {
3021 type => FT_RSRC,
3022 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3023 };
3024 cf::cede_to_tick;
3025
3026 {
3027 my $faces = $facedata->{faceinfo};
3028
3029 while (my ($face, $info) = each %$faces) {
3030 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3031 cf::face::set_visibility $idx, $info->{visibility};
3032 cf::face::set_magicmap $idx, $info->{magicmap};
3033 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3034 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
3035
3036 cf::cede_to_tick;
3037 }
3038
3039 while (my ($face, $info) = each %$faces) {
3040 next unless $info->{smooth};
3041 my $idx = cf::face::find $face
3042 or next;
3043 if (my $smooth = cf::face::find $info->{smooth}) {
3044 cf::face::set_smooth $idx, $smooth;
3045 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3046 } else {
3047 warn "smooth face '$info->{smooth}' not found for face '$face'";
3048 }
3049
3050 cf::cede_to_tick;
3051 }
3052 }
3053
3054 {
3055 my $anims = $facedata->{animinfo};
3056
3057 while (my ($anim, $info) = each %$anims) {
3058 cf::anim::set $anim, $info->{frames}, $info->{facings};
3059 cf::cede_to_tick;
3060 }
3061
3062 cf::anim::invalidate_all; # d'oh
3063 }
3064
3065 {
3066 # TODO: for gcfclient pleasure, we should give resources
3067 # that gcfclient doesn't grok a >10000 face index.
3068 my $res = $facedata->{resource};
3069
3070 my $soundconf = delete $res->{"res/sound.conf"};
3071
3072 while (my ($name, $info) = each %$res) {
3073 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3074 my $data;
3075
3076 if ($info->{type} & 1) {
3077 # prepend meta info
3078
3079 my $meta = $enc->encode ({
3080 name => $name,
3081 %{ $info->{meta} || {} },
3082 });
3083
3084 $data = pack "(w/a*)*", $meta, $info->{data};
3085 } else {
3086 $data = $info->{data};
3087 }
3088
3089 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3090 cf::face::set_type $idx, $info->{type};
3091
3092 cf::cede_to_tick;
3093 }
3094
3095 if ($soundconf) {
3096 $soundconf = $enc->decode (delete $soundconf->{data});
3097
3098 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3099 my $sound = $soundconf->{compat}[$_]
3100 or next;
3101
3102 my $face = cf::face::find "sound/$sound->[1]";
3103 cf::sound::set $sound->[0] => $face;
3104 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3105 }
3106
3107 while (my ($k, $v) = each %{$soundconf->{event}}) {
3108 my $face = cf::face::find "sound/$v";
3109 cf::sound::set $k => $face;
3110 }
3111 }
3112 }
3113
3114 1
3115}
3116
3117register_exticmd fx_want => sub {
3118 my ($ns, $want) = @_;
3119
3120 while (my ($k, $v) = each %$want) {
3121 $ns->fx_want ($k, $v);
3122 }
3123};
3124
3125sub reload_regions {
3126 # HACK to clear player env face cache, we need some signal framework
3127 # for this (global event?)
3128 %ext::player_env::MUSIC_FACE_CACHE = ();
3129
3130 load_resource_file "$MAPDIR/regions"
2263 or die "unable to load regions file\n";#d# 3131 or die "unable to load regions file\n";
2264}
2265 3132
2266sub cfg_load { 3133 for (cf::region::list) {
3134 $_->{match} = qr/$_->{match}/
3135 if exists $_->{match};
3136 }
3137}
3138
3139sub reload_facedata {
3140 load_facedata "$DATADIR/facedata"
3141 or die "unable to load facedata\n";
3142}
3143
3144sub reload_archetypes {
3145 load_resource_file "$DATADIR/archetypes"
3146 or die "unable to load archetypes\n";
3147 #d# NEED to laod twice to resolve forward references
3148 # this really needs to be done in an extra post-pass
3149 # (which needs to be synchronous, so solve it differently)
3150 load_resource_file "$DATADIR/archetypes"
3151 or die "unable to load archetypes\n";
3152}
3153
3154sub reload_treasures {
3155 load_resource_file "$DATADIR/treasures"
3156 or die "unable to load treasurelists\n";
3157}
3158
3159sub reload_resources {
3160 warn "reloading resource files...\n";
3161
3162 reload_regions;
3163 reload_facedata;
3164 #reload_archetypes;#d#
3165 reload_archetypes;
3166 reload_treasures;
3167
3168 warn "finished reloading resource files\n";
3169}
3170
3171sub init {
3172 reload_resources;
3173}
3174
3175sub reload_config {
2267 open my $fh, "<:utf8", cf::confdir . "/config" 3176 open my $fh, "<:utf8", "$CONFDIR/config"
2268 or return; 3177 or return;
2269 3178
2270 local $/; 3179 local $/;
2271 *CFG = YAML::Syck::Load <$fh>; 3180 *CFG = YAML::Syck::Load <$fh>;
2272 3181
… …
2282 }; 3191 };
2283 warn $@ if $@; 3192 warn $@ if $@;
2284 } 3193 }
2285} 3194}
2286 3195
2287sub init {
2288 load_resources;
2289}
2290
2291sub main { 3196sub main {
2292 # we must not ever block the main coroutine 3197 # we must not ever block the main coroutine
2293 local $Coro::idle = sub { 3198 local $Coro::idle = sub {
2294 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3199 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2295 (async { 3200 (async {
3201 $Coro::current->{desc} = "IDLE BUG HANDLER";
2296 Event::one_event; 3202 Event::one_event;
2297 })->prio (Coro::PRIO_MAX); 3203 })->prio (Coro::PRIO_MAX);
2298 }; 3204 };
2299 3205
2300 cfg_load; 3206 reload_config;
2301 db_init; 3207 db_init;
2302 load_extensions; 3208 load_extensions;
2303 3209
2304 $TICK_WATCHER->start; 3210 $TICK_WATCHER->start;
2305 Event::loop; 3211 Event::loop;
… …
2321 }, 3227 },
2322 ); 3228 );
2323 } 3229 }
2324} 3230}
2325 3231
3232sub write_runtime {
3233 my $runtime = "$LOCALDIR/runtime";
3234
3235 # first touch the runtime file to show we are still running:
3236 # the fsync below can take a very very long time.
3237
3238 IO::AIO::aio_utime $runtime, undef, undef;
3239
3240 my $guard = cf::lock_acquire "write_runtime";
3241
3242 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3243 or return;
3244
3245 my $value = $cf::RUNTIME + 90 + 10;
3246 # 10 is the runtime save interval, for a monotonic clock
3247 # 60 allows for the watchdog to kill the server.
3248
3249 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3250 and return;
3251
3252 # always fsync - this file is important
3253 aio_fsync $fh
3254 and return;
3255
3256 # touch it again to show we are up-to-date
3257 aio_utime $fh, undef, undef;
3258
3259 close $fh
3260 or return;
3261
3262 aio_rename "$runtime~", $runtime
3263 and return;
3264
3265 warn "runtime file written.\n";
3266
3267 1
3268}
3269
2326sub emergency_save() { 3270sub emergency_save() {
2327 my $freeze_guard = cf::freeze_mainloop; 3271 my $freeze_guard = cf::freeze_mainloop;
2328 3272
2329 warn "enter emergency perl save\n"; 3273 warn "enter emergency perl save\n";
2330 3274
… …
2361 3305
2362 warn Carp::longmess "post_cleanup backtrace" 3306 warn Carp::longmess "post_cleanup backtrace"
2363 if $make_core; 3307 if $make_core;
2364} 3308}
2365 3309
2366sub reload() { 3310sub do_reload_perl() {
2367 # can/must only be called in main 3311 # can/must only be called in main
2368 if ($Coro::current != $Coro::main) { 3312 if ($Coro::current != $Coro::main) {
2369 warn "can only reload from main coroutine"; 3313 warn "can only reload from main coroutine";
2370 return; 3314 return;
2371 } 3315 }
… …
2396 Coro::cede; 3340 Coro::cede;
2397 last unless IO::AIO::nreqs || BDB::nreqs; 3341 last unless IO::AIO::nreqs || BDB::nreqs;
2398 warn "iterate..."; 3342 warn "iterate...";
2399 } 3343 }
2400 3344
3345 ++$RELOAD;
3346
2401 warn "cancelling all extension coros"; 3347 warn "cancelling all extension coros";
2402 $_->cancel for values %EXT_CORO; 3348 $_->cancel for values %EXT_CORO;
2403 %EXT_CORO = (); 3349 %EXT_CORO = ();
2404 3350
2405 warn "removing commands"; 3351 warn "removing commands";
2406 %COMMAND = (); 3352 %COMMAND = ();
2407 3353
2408 warn "removing ext commands"; 3354 warn "removing ext/exti commands";
2409 %EXTCMD = (); 3355 %EXTCMD = ();
3356 %EXTICMD = ();
2410 3357
2411 warn "unloading/nuking all extensions"; 3358 warn "unloading/nuking all extensions";
2412 for my $pkg (@EXTS) { 3359 for my $pkg (@EXTS) {
2413 warn "... unloading $pkg"; 3360 warn "... unloading $pkg";
2414 3361
… …
2444 Symbol::delete_package "safe::$_" 3391 Symbol::delete_package "safe::$_"
2445 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3392 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2446 3393
2447 warn "unloading cf.pm \"a bit\""; 3394 warn "unloading cf.pm \"a bit\"";
2448 delete $INC{"cf.pm"}; 3395 delete $INC{"cf.pm"};
3396 delete $INC{"cf/pod.pm"};
2449 3397
2450 # don't, removes xs symbols, too, 3398 # don't, removes xs symbols, too,
2451 # and global variables created in xs 3399 # and global variables created in xs
2452 #Symbol::delete_package __PACKAGE__; 3400 #Symbol::delete_package __PACKAGE__;
2453 3401
… …
2456 warn "reloading cf.pm"; 3404 warn "reloading cf.pm";
2457 require cf; 3405 require cf;
2458 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3406 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2459 3407
2460 warn "loading config and database again"; 3408 warn "loading config and database again";
2461 cf::cfg_load; 3409 cf::reload_config;
2462 3410
2463 warn "loading extensions"; 3411 warn "loading extensions";
2464 cf::load_extensions; 3412 cf::load_extensions;
2465 3413
2466 warn "reattaching attachments to objects/players"; 3414 warn "reattaching attachments to objects/players";
2467 _global_reattach; 3415 _global_reattach; # objects, sockets
2468 warn "reattaching attachments to maps"; 3416 warn "reattaching attachments to maps";
2469 reattach $_ for values %MAP; 3417 reattach $_ for values %MAP;
2470 3418 warn "reattaching attachments to players";
2471 warn "loading reloadable resources"; 3419 reattach $_ for values %PLAYER;
2472 load_resources;
2473 3420
2474 warn "leaving sync_job"; 3421 warn "leaving sync_job";
2475 3422
2476 1 3423 1
2477 } or do { 3424 } or do {
… …
2483 warn "reloaded"; 3430 warn "reloaded";
2484}; 3431};
2485 3432
2486our $RELOAD_WATCHER; # used only during reload 3433our $RELOAD_WATCHER; # used only during reload
2487 3434
3435sub reload_perl() {
3436 # doing reload synchronously and two reloads happen back-to-back,
3437 # coro crashes during coro_state_free->destroy here.
3438
3439 $RELOAD_WATCHER ||= Event->timer (
3440 reentrant => 0,
3441 after => 0,
3442 data => WF_AUTOCANCEL,
3443 cb => sub {
3444 do_reload_perl;
3445 undef $RELOAD_WATCHER;
3446 },
3447 );
3448}
3449
2488register_command "reload" => sub { 3450register_command "reload" => sub {
2489 my ($who, $arg) = @_; 3451 my ($who, $arg) = @_;
2490 3452
2491 if ($who->flag (FLAG_WIZ)) { 3453 if ($who->flag (FLAG_WIZ)) {
2492 $who->message ("reloading server."); 3454 $who->message ("reloading server.");
2493 3455 async {
2494 # doing reload synchronously and two reloads happen back-to-back, 3456 $Coro::current->{desc} = "perl_reload";
2495 # coro crashes during coro_state_free->destroy here.
2496
2497 $RELOAD_WATCHER ||= Event->timer (
2498 reentrant => 0,
2499 after => 0,
2500 data => WF_AUTOCANCEL,
2501 cb => sub {
2502 reload; 3457 reload_perl;
2503 undef $RELOAD_WATCHER;
2504 },
2505 ); 3458 };
2506 } 3459 }
2507}; 3460};
2508 3461
2509unshift @INC, $LIBDIR; 3462unshift @INC, $LIBDIR;
2510 3463
2511my $bug_warning = 0; 3464my $bug_warning = 0;
3465
3466our @WAIT_FOR_TICK;
3467our @WAIT_FOR_TICK_BEGIN;
3468
3469sub wait_for_tick {
3470 return unless $TICK_WATCHER->is_active;
3471 return if $Coro::current == $Coro::main;
3472
3473 my $signal = new Coro::Signal;
3474 push @WAIT_FOR_TICK, $signal;
3475 $signal->wait;
3476}
3477
3478sub wait_for_tick_begin {
3479 return unless $TICK_WATCHER->is_active;
3480 return if $Coro::current == $Coro::main;
3481
3482 my $signal = new Coro::Signal;
3483 push @WAIT_FOR_TICK_BEGIN, $signal;
3484 $signal->wait;
3485}
2512 3486
2513$TICK_WATCHER = Event->timer ( 3487$TICK_WATCHER = Event->timer (
2514 reentrant => 0, 3488 reentrant => 0,
2515 parked => 1, 3489 parked => 1,
2516 prio => 0, 3490 prio => 0,
… …
2521 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3495 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2522 unless ++$bug_warning > 10; 3496 unless ++$bug_warning > 10;
2523 return; 3497 return;
2524 } 3498 }
2525 3499
2526 $NOW = Event::time; 3500 $NOW = $tick_start = Event::time;
2527 3501
2528 cf::server_tick; # one server iteration 3502 cf::server_tick; # one server iteration
3503
2529 $RUNTIME += $TICK; 3504 $RUNTIME += $TICK;
2530 $NEXT_TICK += $TICK; 3505 $NEXT_TICK += $TICK;
2531 3506
2532 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3507 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2533 $NEXT_RUNTIME_WRITE = $NOW + 10; 3508 $NEXT_RUNTIME_WRITE = $NOW + 10;
2534 Coro::async_pool { 3509 Coro::async_pool {
3510 $Coro::current->{desc} = "runtime saver";
2535 write_runtime 3511 write_runtime
2536 or warn "ERROR: unable to write runtime file: $!"; 3512 or warn "ERROR: unable to write runtime file: $!";
2537 }; 3513 };
2538 } 3514 }
2539 3515
3516 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3517 $sig->send;
3518 }
3519 while (my $sig = shift @WAIT_FOR_TICK) {
3520 $sig->send;
3521 }
2540 3522
2541 $WAIT_FOR_TICK->broadcast; 3523 $NOW = Event::time;
2542 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2543
2544# my $AFTER = Event::time;
2545# warn $AFTER - $NOW;#d#
2546 3524
2547 # if we are delayed by four ticks or more, skip them all 3525 # if we are delayed by four ticks or more, skip them all
2548 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3526 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2549 3527
2550 $TICK_WATCHER->at ($NEXT_TICK); 3528 $TICK_WATCHER->at ($NEXT_TICK);
2551 $TICK_WATCHER->start; 3529 $TICK_WATCHER->start;
3530
3531 $LOAD = ($NOW - $tick_start) / $TICK;
3532 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3533
3534 _post_tick;
2552 }, 3535 },
2553); 3536);
2554 3537
2555{ 3538{
3539 BDB::min_parallel 8;
2556 BDB::max_poll_time $TICK * 0.1; 3540 BDB::max_poll_time $TICK * 0.1;
2557 $BDB_POLL_WATCHER = Event->io ( 3541 $BDB_POLL_WATCHER = Event->io (
2558 reentrant => 0, 3542 reentrant => 0,
2559 fd => BDB::poll_fileno, 3543 fd => BDB::poll_fileno,
2560 poll => 'r', 3544 poll => 'r',
2561 prio => 0, 3545 prio => 0,
2562 data => WF_AUTOCANCEL, 3546 data => WF_AUTOCANCEL,
2563 cb => \&BDB::poll_cb, 3547 cb => \&BDB::poll_cb,
2564 ); 3548 );
2565 BDB::min_parallel 8;
2566 3549
2567 BDB::set_sync_prepare { 3550 BDB::set_sync_prepare {
2568 my $status; 3551 my $status;
2569 my $current = $Coro::current; 3552 my $current = $Coro::current;
2570 ( 3553 (
… …
2579 ) 3562 )
2580 }; 3563 };
2581 3564
2582 unless ($DB_ENV) { 3565 unless ($DB_ENV) {
2583 $DB_ENV = BDB::db_env_create; 3566 $DB_ENV = BDB::db_env_create;
3567 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3568 | BDB::LOG_AUTOREMOVE, 1);
3569 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3570 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2584 3571
2585 cf::sync_job { 3572 cf::sync_job {
2586 eval { 3573 eval {
2587 BDB::db_env_open 3574 BDB::db_env_open
2588 $DB_ENV, 3575 $DB_ENV,
2589 $BDB_ENV_DIR, 3576 $BDBDIR,
2590 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3577 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2591 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3578 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2592 0666; 3579 0666;
2593 3580
2594 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3581 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2595
2596 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2597 $DB_ENV->set_lk_detect;
2598 }; 3582 };
2599 3583
2600 cf::cleanup "db_env_open(db): $@" if $@; 3584 cf::cleanup "db_env_open(db): $@" if $@;
2601 }; 3585 };
2602 } 3586 }
3587
3588 $BDB_DEADLOCK_WATCHER = Event->timer (
3589 after => 3,
3590 interval => 1,
3591 hard => 1,
3592 prio => 0,
3593 data => WF_AUTOCANCEL,
3594 cb => sub {
3595 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3596 },
3597 );
3598 $BDB_CHECKPOINT_WATCHER = Event->timer (
3599 after => 11,
3600 interval => 60,
3601 hard => 1,
3602 prio => 0,
3603 data => WF_AUTOCANCEL,
3604 cb => sub {
3605 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3606 },
3607 );
3608 $BDB_TRICKLE_WATCHER = Event->timer (
3609 after => 5,
3610 interval => 10,
3611 hard => 1,
3612 prio => 0,
3613 data => WF_AUTOCANCEL,
3614 cb => sub {
3615 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3616 },
3617 );
2603} 3618}
2604 3619
2605{ 3620{
2606 IO::AIO::min_parallel 8; 3621 IO::AIO::min_parallel 8;
2607 3622
… …
2610 $AIO_POLL_WATCHER = Event->io ( 3625 $AIO_POLL_WATCHER = Event->io (
2611 reentrant => 0, 3626 reentrant => 0,
2612 data => WF_AUTOCANCEL, 3627 data => WF_AUTOCANCEL,
2613 fd => IO::AIO::poll_fileno, 3628 fd => IO::AIO::poll_fileno,
2614 poll => 'r', 3629 poll => 'r',
2615 prio => 6, 3630 prio => 0,
2616 cb => \&IO::AIO::poll_cb, 3631 cb => \&IO::AIO::poll_cb,
2617 ); 3632 );
2618} 3633}
2619 3634
3635my $_log_backtrace;
3636
3637sub _log_backtrace {
3638 my ($msg, @addr) = @_;
3639
3640 $msg =~ s/\n//;
3641
3642 # limit the # of concurrent backtraces
3643 if ($_log_backtrace < 2) {
3644 ++$_log_backtrace;
3645 async {
3646 $Coro::current->{desc} = "abt $msg";
3647
3648 my @bt = fork_call {
3649 @addr = map { sprintf "%x", $_ } @addr;
3650 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3651 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3652 or die "addr2line: $!";
3653
3654 my @funcs;
3655 my @res = <$fh>;
3656 chomp for @res;
3657 while (@res) {
3658 my ($func, $line) = splice @res, 0, 2, ();
3659 push @funcs, "[$func] $line";
3660 }
3661
3662 @funcs
3663 };
3664
3665 LOG llevInfo, "[ABT] $msg\n";
3666 LOG llevInfo, "[ABT] $_\n" for @bt;
3667 --$_log_backtrace;
3668 };
3669 } else {
3670 LOG llevInfo, "[ABT] $msg\n";
3671 LOG llevInfo, "[ABT] [suppressed]\n";
3672 }
3673}
3674
3675# load additional modules
3676use cf::pod;
3677
2620END { cf::emergency_save } 3678END { cf::emergency_save }
2621 3679
26221 36801
2623 3681

Diff Legend

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