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

Diff Legend

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