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.379 by root, Thu Oct 4 23:59:07 2007 UTC

… …
3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
10use Event;
9use Opcode; 11use Opcode;
10use Safe; 12use Safe;
11use Safe::Hole; 13use Safe::Hole;
12 14
13use Coro 3.5 (); 15use Coro 3.64 ();
16use Coro::State;
17use Coro::Handle;
14use Coro::Event; 18use Coro::Event;
15use Coro::Timer; 19use Coro::Timer;
16use Coro::Signal; 20use Coro::Signal;
17use Coro::Semaphore; 21use Coro::Semaphore;
18use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
24use Coro::Util ();
19 25
26use JSON::XS ();
27use BDB ();
20use Data::Dumper; 28use Data::Dumper;
21use Digest::MD5; 29use Digest::MD5;
22use Fcntl; 30use Fcntl;
31use YAML::Syck ();
23use IO::AIO 2.32 (); 32use IO::AIO 2.32 ();
24use YAML::Syck ();
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 = 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;
1091
812 $av = eval { (Storable::thaw $av)->{objs} }; 1092 $av = eval { (Storable::thaw $av)->{objs} };
813 } 1093 }
814 1094
1095 utf8::decode (my $decname = $filename);
815 warn sprintf "loading %s (%d)\n", 1096 warn sprintf "loading %s (%d,%d)\n",
816 $filename, length $data, scalar @{$av || []};#d# 1097 $decname, length $data, scalar @{$av || []};
1098
817 return ($data, $av); 1099 ($data, $av)
818} 1100}
1101
1102=head2 COMMAND CALLBACKS
1103
1104=over 4
1105
1106=cut
819 1107
820############################################################################# 1108#############################################################################
821# command handling &c 1109# command handling &c
822 1110
823=item cf::register_command $name => \&callback($ob,$args); 1111=item cf::register_command $name => \&callback($ob,$args);
… …
836 push @{ $COMMAND{$name} }, [$caller, $cb]; 1124 push @{ $COMMAND{$name} }, [$caller, $cb];
837} 1125}
838 1126
839=item cf::register_extcmd $name => \&callback($pl,$packet); 1127=item cf::register_extcmd $name => \&callback($pl,$packet);
840 1128
841Register a callbackf ro execution when the client sends an extcmd packet. 1129Register a callback for execution when the client sends an (synchronous)
1130extcmd packet. Ext commands will be processed in the order they are
1131received by the server, like other user commands. The first argument is
1132the logged-in player. Ext commands can only be processed after a player
1133has logged in successfully.
842 1134
843If the callback returns something, it is sent back as if reply was being 1135If the callback returns something, it is sent back as if reply was being
844called. 1136called.
845 1137
1138=item cf::register_exticmd $name => \&callback($ns,$packet);
1139
1140Register a callback for execution when the client sends an (asynchronous)
1141exticmd packet. Exti commands are processed by the server as soon as they
1142are received, i.e. out of order w.r.t. other commands. The first argument
1143is a client socket. Exti commands can be received anytime, even before
1144log-in.
1145
1146If the callback returns something, it is sent back as if reply was being
1147called.
1148
846=cut 1149=cut
847 1150
848sub register_extcmd { 1151sub register_extcmd {
849 my ($name, $cb) = @_; 1152 my ($name, $cb) = @_;
850 1153
851 $EXTCMD{$name} = $cb; 1154 $EXTCMD{$name} = $cb;
1155}
1156
1157sub register_exticmd {
1158 my ($name, $cb) = @_;
1159
1160 $EXTICMD{$name} = $cb;
852} 1161}
853 1162
854cf::player->attach ( 1163cf::player->attach (
855 on_command => sub { 1164 on_command => sub {
856 my ($pl, $name, $params) = @_; 1165 my ($pl, $name, $params) = @_;
… …
865 cf::override; 1174 cf::override;
866 }, 1175 },
867 on_extcmd => sub { 1176 on_extcmd => sub {
868 my ($pl, $buf) = @_; 1177 my ($pl, $buf) = @_;
869 1178
870 my $msg = eval { from_json $buf }; 1179 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
871 1180
872 if (ref $msg) { 1181 if (ref $msg) {
1182 my ($type, $reply, @payload) =
1183 "ARRAY" eq ref $msg
1184 ? @$msg
1185 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1186
1187 my @reply;
1188
873 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1189 if (my $cb = $EXTCMD{$type}) {
874 if (my %reply = $cb->($pl, $msg)) { 1190 @reply = $cb->($pl, @payload);
875 $pl->ext_reply ($msg->{msgid}, %reply);
876 }
877 } 1191 }
1192
1193 $pl->ext_reply ($reply, @reply)
1194 if $reply;
1195
878 } else { 1196 } else {
879 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1197 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
880 } 1198 }
881 1199
882 cf::override; 1200 cf::override;
883 }, 1201 },
884); 1202);
885 1203
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 { 1204sub load_extensions {
1205 cf::sync_job {
1206 my %todo;
1207
921 for my $ext (<$LIBDIR/*.ext>) { 1208 for my $path (<$LIBDIR/*.ext>) {
922 next unless -r $ext; 1209 next unless -r $path;
923 eval { 1210
924 load_extension $ext; 1211 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1212 my $base = $1;
1213 my $pkg = $1;
1214 $pkg =~ s/[^[:word:]]/_/g;
1215 $pkg = "ext::$pkg";
1216
1217 open my $fh, "<:utf8", $path
1218 or die "$path: $!";
1219
1220 my $source = do { local $/; <$fh> };
1221
1222 my %ext = (
1223 path => $path,
1224 base => $base,
1225 pkg => $pkg,
1226 );
1227
1228 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1229 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1230
1231 $ext{source} =
1232 "package $pkg; use strict; use utf8;\n"
1233 . "#line 1 \"$path\"\n{\n"
1234 . $source
1235 . "\n};\n1";
1236
1237 $todo{$base} = \%ext;
1238 }
1239
1240 my %done;
1241 while (%todo) {
1242 my $progress;
1243
1244 while (my ($k, $v) = each %todo) {
1245 for (split /,\s*/, $v->{meta}{depends}) {
1246 goto skip
1247 unless exists $done{$_};
1248 }
1249
1250 warn "... loading '$k' into '$v->{pkg}'\n";
1251
1252 unless (eval $v->{source}) {
1253 my $msg = $@ ? "$v->{path}: $@\n"
1254 : "$v->{base}: extension inactive.\n";
1255
1256 if (exists $v->{meta}{mandatory}) {
1257 warn $msg;
1258 warn "mandatory extension failed to load, exiting.\n";
1259 exit 1;
1260 }
1261
1262 warn $msg;
1263 }
1264
1265 $done{$k} = delete $todo{$k};
1266 push @EXTS, $v->{pkg};
1267 $progress = 1;
925 1 1268 }
926 } or warn "$ext not loaded: $@"; 1269
1270 skip:
1271 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1272 unless $progress;
1273 }
927 } 1274 };
928} 1275}
929 1276
930############################################################################# 1277#############################################################################
931 1278
1279=back
1280
932=head2 CORE EXTENSIONS 1281=head2 CORE EXTENSIONS
933 1282
934Functions and methods that extend core crossfire objects. 1283Functions and methods that extend core crossfire objects.
935 1284
936=cut 1285=cut
… …
941 1290
942=head3 cf::player 1291=head3 cf::player
943 1292
944=over 4 1293=over 4
945 1294
1295=item cf::player::num_playing
1296
1297Returns the official number of playing players, as per the Crossfire metaserver rules.
1298
1299=cut
1300
1301sub num_playing {
1302 scalar grep
1303 $_->ob->map
1304 && !$_->hidden
1305 && !$_->ob->flag (cf::FLAG_WIZ),
1306 cf::player::list
1307}
1308
946=item cf::player::find $login 1309=item cf::player::find $login
947 1310
948Returns the given player object, loading it if necessary (might block). 1311Returns the given player object, loading it if necessary (might block).
949 1312
950=cut 1313=cut
951 1314
952sub playerdir($) { 1315sub playerdir($) {
953 cf::localdir 1316 "$PLAYERDIR/"
954 . "/"
955 . cf::playerdir
956 . "/"
957 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1317 . (ref $_[0] ? $_[0]->ob->name : $_[0])
958} 1318}
959 1319
960sub path($) { 1320sub path($) {
961 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1321 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
962 1322
963 (playerdir $login) . "/$login.pl" 1323 (playerdir $login) . "/playerdata"
964} 1324}
965 1325
966sub find_active($) { 1326sub find_active($) {
967 $cf::PLAYER{$_[0]} 1327 $cf::PLAYER{$_[0]}
968 and $cf::PLAYER{$_[0]}->active 1328 and $cf::PLAYER{$_[0]}->active
… …
981 my $login = $_[0]; 1341 my $login = $_[0];
982 1342
983 my $guard = cf::lock_acquire "user_find:$login"; 1343 my $guard = cf::lock_acquire "user_find:$login";
984 1344
985 $cf::PLAYER{$_[0]} || do { 1345 $cf::PLAYER{$_[0]} || do {
986 my $pl = load_pl path $login 1346 # rename old playerfiles to new ones
1347 #TODO: remove when no longer required
1348 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1349 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1350 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1351 aio_unlink +(playerdir $login) . "/$login.pl";
1352
1353 my $f = new_from_file cf::object::thawer path $login
987 or return; 1354 or return;
1355
1356 my $pl = cf::player::load_pl $f
1357 or return;
1358 local $cf::PLAYER_LOADING{$login} = $pl;
1359 $f->resolve_delayed_derefs;
988 $cf::PLAYER{$login} = $pl 1360 $cf::PLAYER{$login} = $pl
989 } 1361 }
990 } 1362 }
991} 1363}
992 1364
… …
1002 1374
1003 aio_mkdir playerdir $pl, 0770; 1375 aio_mkdir playerdir $pl, 0770;
1004 $pl->{last_save} = $cf::RUNTIME; 1376 $pl->{last_save} = $cf::RUNTIME;
1005 1377
1006 $pl->save_pl ($path); 1378 $pl->save_pl ($path);
1007 Coro::cede; 1379 cf::cede_to_tick;
1008} 1380}
1009 1381
1010sub new($) { 1382sub new($) {
1011 my ($login) = @_; 1383 my ($login) = @_;
1012 1384
… …
1018 $cf::PLAYER{$login} = $self; 1390 $cf::PLAYER{$login} = $self;
1019 1391
1020 $self 1392 $self
1021} 1393}
1022 1394
1395=item $player->send_msg ($channel, $msg, $color, [extra...])
1396
1397=cut
1398
1399sub send_msg {
1400 my $ns = shift->ns
1401 or return;
1402 $ns->send_msg (@_);
1403}
1404
1023=item $pl->quit_character 1405=item $pl->quit_character
1024 1406
1025Nukes the player without looking back. If logged in, the connection will 1407Nukes the player without looking back. If logged in, the connection will
1026be destroyed. May block for a long time. 1408be destroyed. May block for a long time.
1027 1409
1028=cut 1410=cut
1029 1411
1030sub quit_character { 1412sub quit_character {
1031 my ($pl) = @_; 1413 my ($pl) = @_;
1414
1415 my $name = $pl->ob->name;
1032 1416
1033 $pl->{deny_save} = 1; 1417 $pl->{deny_save} = 1;
1034 $pl->password ("*"); # this should lock out the player until we nuked the dir 1418 $pl->password ("*"); # this should lock out the player until we nuked the dir
1035 1419
1036 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1420 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1041 my $path = playerdir $pl; 1425 my $path = playerdir $pl;
1042 my $temp = "$path~$cf::RUNTIME~deleting~"; 1426 my $temp = "$path~$cf::RUNTIME~deleting~";
1043 aio_rename $path, $temp; 1427 aio_rename $path, $temp;
1044 delete $cf::PLAYER{$pl->ob->name}; 1428 delete $cf::PLAYER{$pl->ob->name};
1045 $pl->destroy; 1429 $pl->destroy;
1430
1431 my $prefix = qr<^~\Q$name\E/>;
1432
1433 # nuke player maps
1434 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1435
1046 IO::AIO::aio_rmtree $temp; 1436 IO::AIO::aio_rmtree $temp;
1437}
1438
1439=item $pl->kick
1440
1441Kicks a player out of the game. This destroys the connection.
1442
1443=cut
1444
1445sub kick {
1446 my ($pl, $kicker) = @_;
1447
1448 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1449 $pl->killer ("kicked");
1450 $pl->ns->destroy;
1047} 1451}
1048 1452
1049=item cf::player::list_logins 1453=item cf::player::list_logins
1050 1454
1051Returns am arrayref of all valid playernames in the system, can take a 1455Returns am arrayref of all valid playernames in the system, can take a
1052while and may block, so not sync_job-capable, ever. 1456while and may block, so not sync_job-capable, ever.
1053 1457
1054=cut 1458=cut
1055 1459
1056sub list_logins { 1460sub list_logins {
1057 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1461 my $dirs = aio_readdir $PLAYERDIR
1058 or return []; 1462 or return [];
1059 1463
1060 my @logins; 1464 my @logins;
1061 1465
1062 for my $login (@$dirs) { 1466 for my $login (@$dirs) {
1467 my $path = path $login;
1468
1469 # a .pst is a dead give-away for a valid player
1470 unless (-e "$path.pst") {
1063 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1471 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1064 aio_read $fh, 0, 512, my $buf, 0 or next; 1472 aio_read $fh, 0, 512, my $buf, 0 or next;
1065 $buf !~ /^password -------------$/m or next; # official not-valid tag 1473 $buf !~ /^password -------------$/m or next; # official not-valid tag
1474 }
1066 1475
1067 utf8::decode $login; 1476 utf8::decode $login;
1068 push @logins, $login; 1477 push @logins, $login;
1069 } 1478 }
1070 1479
… …
1097 } 1506 }
1098 1507
1099 \@paths 1508 \@paths
1100} 1509}
1101 1510
1511=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1512
1513Expand crossfire pod fragments into protocol xml.
1514
1515=cut
1516
1517sub expand_cfpod {
1518 ((my $self), (local $_)) = @_;
1519
1520 # escape & and <
1521 s/&/&amp;/g;
1522 s/(?<![BIUGHT])</&lt;/g;
1523
1524 # this is buggy, it needs to properly take care of nested <'s
1525
1526 1 while
1527 # replace B<>, I<>, U<> etc.
1528 s/B<([^\>]*)>/<b>$1<\/b>/
1529 || s/I<([^\>]*)>/<i>$1<\/i>/
1530 || s/U<([^\>]*)>/<u>$1<\/u>/
1531 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1532 # replace G<male|female> tags
1533 || s{G<([^>|]*)\|([^>]*)>}{
1534 $self->gender ? $2 : $1
1535 }ge
1536 # replace H<hint text>
1537 || s{H<([^\>]*)>}
1538 {
1539 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1540 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1541 "")
1542 [$self->{hintmode}]
1543 }ge;
1544
1545 # create single paragraphs (very hackish)
1546 s/(?<=\S)\n(?=\w)/ /g;
1547
1548 # compress some whitespace
1549 s/\s+\n/\n/g; # ws line-ends
1550 s/\n\n+/\n/g; # double lines
1551 s/^\n+//; # beginning lines
1552 s/\n+$//; # ending lines
1553
1554 $_
1555}
1556
1557sub hintmode {
1558 $_[0]{hintmode} = $_[1] if @_ > 1;
1559 $_[0]{hintmode}
1560}
1561
1102=item $player->ext_reply ($msgid, $msgtype, %msg) 1562=item $player->ext_reply ($msgid, @msg)
1103 1563
1104Sends an ext reply to the player. 1564Sends an ext reply to the player.
1105 1565
1106=cut 1566=cut
1107 1567
1108sub ext_reply($$$%) { 1568sub ext_reply($$@) {
1109 my ($self, $id, %msg) = @_; 1569 my ($self, $id, @msg) = @_;
1110 1570
1111 $msg{msgid} = $id; 1571 $self->ns->ext_reply ($id, @msg)
1112
1113 $self->send ("ext " . cf::to_json \%msg);
1114} 1572}
1115 1573
1116package cf; 1574=item $player->ext_msg ($type, @msg)
1575
1576Sends an ext event to the client.
1577
1578=cut
1579
1580sub ext_msg($$@) {
1581 my ($self, $type, @msg) = @_;
1582
1583 $self->ns->ext_msg ($type, @msg);
1584}
1585
1586=head3 cf::region
1587
1588=over 4
1589
1590=cut
1591
1592package cf::region;
1593
1594=item cf::region::find_by_path $path
1595
1596Tries to decuce the likely region for a map knowing only its path.
1597
1598=cut
1599
1600sub find_by_path($) {
1601 my ($path) = @_;
1602
1603 my ($match, $specificity);
1604
1605 for my $region (list) {
1606 if ($region->{match} && $path =~ $region->{match}) {
1607 ($match, $specificity) = ($region, $region->specificity)
1608 if $region->specificity > $specificity;
1609 }
1610 }
1611
1612 $match
1613}
1117 1614
1118=back 1615=back
1119
1120 1616
1121=head3 cf::map 1617=head3 cf::map
1122 1618
1123=over 4 1619=over 4
1124 1620
… …
1179 my ($self, $merge) = @_; 1675 my ($self, $merge) = @_;
1180 1676
1181 # we have to keep some variables in memory intact 1677 # we have to keep some variables in memory intact
1182 local $self->{path}; 1678 local $self->{path};
1183 local $self->{load_path}; 1679 local $self->{load_path};
1184 local $self->{deny_save};
1185 local $self->{deny_reset};
1186 1680
1187 $self->SUPER::thawer_merge ($merge); 1681 $self->SUPER::thawer_merge ($merge);
1188} 1682}
1189 1683
1190sub normalise { 1684sub normalise {
… …
1237 $self->init; # pass $1 etc. 1731 $self->init; # pass $1 etc.
1238 return $self; 1732 return $self;
1239 } 1733 }
1240 } 1734 }
1241 1735
1242 Carp::carp "unable to resolve path '$path' (base '$base')."; 1736 Carp::cluck "unable to resolve path '$path' (base '$base').";
1243 () 1737 ()
1244} 1738}
1245 1739
1246sub init { 1740sub init {
1247 my ($self) = @_; 1741 my ($self) = @_;
… …
1262 1756
1263# the original (read-only) location 1757# the original (read-only) location
1264sub load_path { 1758sub load_path {
1265 my ($self) = @_; 1759 my ($self) = @_;
1266 1760
1267 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1761 "$MAPDIR/$self->{path}.map"
1268} 1762}
1269 1763
1270# the temporary/swap location 1764# the temporary/swap location
1271sub save_path { 1765sub save_path {
1272 my ($self) = @_; 1766 my ($self) = @_;
1273 1767
1274 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1768 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1275 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1769 "$TMPDIR/$path.map"
1276} 1770}
1277 1771
1278# the unique path, undef == no special unique path 1772# the unique path, undef == no special unique path
1279sub uniq_path { 1773sub uniq_path {
1280 my ($self) = @_; 1774 my ($self) = @_;
1281 1775
1282 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1776 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1283 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1777 "$UNIQUEDIR/$path"
1284} 1778}
1285 1779
1286# and all this just because we cannot iterate over 1780# and all this just because we cannot iterate over
1287# all maps in C++... 1781# all maps in C++...
1288sub change_all_map_light { 1782sub change_all_map_light {
… …
1290 1784
1291 $_->change_map_light ($change) 1785 $_->change_map_light ($change)
1292 for grep $_->outdoor, values %cf::MAP; 1786 for grep $_->outdoor, values %cf::MAP;
1293} 1787}
1294 1788
1789sub decay_objects {
1790 my ($self) = @_;
1791
1792 return if $self->{deny_reset};
1793
1794 $self->do_decay_objects;
1795}
1796
1295sub unlink_save { 1797sub unlink_save {
1296 my ($self) = @_; 1798 my ($self) = @_;
1297 1799
1298 utf8::encode (my $save = $self->save_path); 1800 utf8::encode (my $save = $self->save_path);
1299 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1801 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1300 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst"; 1802 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} 1803}
1307 1804
1308sub load_header_from($) { 1805sub load_header_from($) {
1309 my ($self, $path) = @_; 1806 my ($self, $path) = @_;
1310 1807
1311 utf8::encode $path; 1808 utf8::encode $path;
1312 #aio_open $path, O_RDONLY, 0 1809 my $f = new_from_file cf::object::thawer $path
1313 # or return;
1314
1315 $self->_load_header ($path)
1316 or return; 1810 or return;
1811
1812 $self->_load_header ($f)
1813 or return;
1814
1815 local $MAP_LOADING{$self->{path}} = $self;
1816 $f->resolve_delayed_derefs;
1317 1817
1318 $self->{load_path} = $path; 1818 $self->{load_path} = $path;
1319 1819
1320 1 1820 1
1321} 1821}
… …
1360 $self->load_header_orig 1860 $self->load_header_orig
1361 or return; 1861 or return;
1362 $self->prepare_orig; 1862 $self->prepare_orig;
1363 } 1863 }
1364 1864
1865 $self->{deny_reset} = 1
1866 if $self->no_reset;
1867
1868 $self->default_region (cf::region::find_by_path $self->{path})
1869 unless $self->default_region;
1870
1365 1 1871 1
1366} 1872}
1367 1873
1368sub find; 1874sub find;
1369sub find { 1875sub find {
1370 my ($path, $origin) = @_; 1876 my ($path, $origin) = @_;
1371 1877
1372 $path = normalise $path, $origin && $origin->path; 1878 $path = normalise $path, $origin && $origin->path;
1373 1879
1880 cf::lock_wait "map_data:$path";#d#remove
1374 cf::lock_wait "map_find:$path"; 1881 cf::lock_wait "map_find:$path";
1375 1882
1376 $cf::MAP{$path} || do { 1883 $cf::MAP{$path} || do {
1377 my $guard = cf::lock_acquire "map_find:$path"; 1884 my $guard1 = cf::lock_acquire "map_find:$path";
1885 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1886
1378 my $map = new_from_path cf::map $path 1887 my $map = new_from_path cf::map $path
1379 or return; 1888 or return;
1380 1889
1381 $map->{last_save} = $cf::RUNTIME; 1890 $map->{last_save} = $cf::RUNTIME;
1382 1891
1383 $map->load_header 1892 $map->load_header
1384 or return; 1893 or return;
1385 1894
1386 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1895 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1387 # doing this can freeze the server in a sync job, obviously 1896 # doing this can freeze the server in a sync job, obviously
1388 #$cf::WAIT_FOR_TICK->wait; 1897 #$cf::WAIT_FOR_TICK->wait;
1898 undef $guard1;
1899 undef $guard2;
1389 $map->reset; 1900 $map->reset;
1390 undef $guard;
1391 return find $path; 1901 return find $path;
1392 } 1902 }
1393 1903
1394 $cf::MAP{$path} = $map 1904 $cf::MAP{$path} = $map
1395 } 1905 }
… …
1402 my ($self) = @_; 1912 my ($self) = @_;
1403 1913
1404 local $self->{deny_reset} = 1; # loading can take a long time 1914 local $self->{deny_reset} = 1; # loading can take a long time
1405 1915
1406 my $path = $self->{path}; 1916 my $path = $self->{path};
1917
1918 {
1407 my $guard = cf::lock_acquire "map_load:$path"; 1919 my $guard = cf::lock_acquire "map_data:$path";
1408 1920
1921 return unless $self->valid;
1409 return if $self->in_memory != cf::MAP_SWAPPED; 1922 return unless $self->in_memory == cf::MAP_SWAPPED;
1410 1923
1411 $self->in_memory (cf::MAP_LOADING); 1924 $self->in_memory (cf::MAP_LOADING);
1412 1925
1413 $self->alloc; 1926 $self->alloc;
1414 1927
1415 $self->pre_load; 1928 $self->pre_load;
1929 cf::cede_to_tick;
1416 1930
1417 $self->_load_objects ($self->{load_path}, 1) 1931 my $f = new_from_file cf::object::thawer $self->{load_path};
1932 $f->skip_block;
1933 $self->_load_objects ($f)
1418 or return; 1934 or return;
1419 1935
1420 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1936 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1421 if delete $self->{load_original}; 1937 if delete $self->{load_original};
1422 1938
1423 if (my $uniq = $self->uniq_path) { 1939 if (my $uniq = $self->uniq_path) {
1424 utf8::encode $uniq; 1940 utf8::encode $uniq;
1425 if (aio_open $uniq, O_RDONLY, 0) { 1941 unless (aio_stat $uniq) {
1942 if (my $f = new_from_file cf::object::thawer $uniq) {
1426 $self->clear_unique_items; 1943 $self->clear_unique_items;
1427 $self->_load_objects ($uniq, 0); 1944 $self->_load_objects ($f);
1945 $f->resolve_delayed_derefs;
1946 }
1428 } 1947 }
1429 } 1948 }
1430 1949
1431 Coro::cede; 1950 $f->resolve_delayed_derefs;
1432 1951
1952 cf::cede_to_tick;
1433 # now do the right thing for maps 1953 # now do the right thing for maps
1434 $self->link_multipart_objects; 1954 $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) 1955 $self->difficulty ($self->estimate_difficulty)
1443 unless $self->difficulty; 1956 unless $self->difficulty;
1444 Coro::cede; 1957 cf::cede_to_tick;
1958
1959 unless ($self->{deny_activate}) {
1960 $self->decay_objects;
1961 $self->fix_auto_apply;
1962 $self->update_buttons;
1963 cf::cede_to_tick;
1964 $self->set_darkness_map;
1965 cf::cede_to_tick;
1445 $self->activate; 1966 $self->activate;
1967 }
1968
1969 $self->{last_save} = $cf::RUNTIME;
1970 $self->last_access ($cf::RUNTIME);
1971
1972 $self->in_memory (cf::MAP_IN_MEMORY);
1446 } 1973 }
1447 1974
1448 $self->post_load; 1975 $self->post_load;
1449
1450 $self->in_memory (cf::MAP_IN_MEMORY);
1451} 1976}
1452 1977
1453sub customise_for { 1978sub customise_for {
1454 my ($self, $ob) = @_; 1979 my ($self, $ob) = @_;
1455 1980
1456 return find "~" . $ob->name . "/" . $self->{path} 1981 return find "~" . $ob->name . "/" . $self->{path}
1457 if $self->per_player; 1982 if $self->per_player;
1458 1983
1984# return find "?party/" . $ob->name . "/" . $self->{path}
1985# if $self->per_party;
1986
1459 $self 1987 $self
1460} 1988}
1461 1989
1462# find and load all maps in the 3x3 area around a map 1990# find and load all maps in the 3x3 area around a map
1463sub load_diag { 1991sub load_neighbours {
1464 my ($map) = @_; 1992 my ($map) = @_;
1465 1993
1466 my @diag; # diagonal neighbours 1994 my @neigh; # diagonal neighbours
1467 1995
1468 for (0 .. 3) { 1996 for (0 .. 3) {
1469 my $neigh = $map->tile_path ($_) 1997 my $neigh = $map->tile_path ($_)
1470 or next; 1998 or next;
1471 $neigh = find $neigh, $map 1999 $neigh = find $neigh, $map
1472 or next; 2000 or next;
1473 $neigh->load; 2001 $neigh->load;
1474 2002
2003 push @neigh,
1475 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2004 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1476 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2005 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1477 } 2006 }
1478 2007
1479 for (@diag) { 2008 for (grep defined $_->[0], @neigh) {
2009 my ($path, $origin) = @$_;
1480 my $neigh = find @$_ 2010 my $neigh = find $path, $origin
1481 or next; 2011 or next;
1482 $neigh->load; 2012 $neigh->load;
1483 } 2013 }
1484} 2014}
1485 2015
… …
1490} 2020}
1491 2021
1492sub do_load_sync { 2022sub do_load_sync {
1493 my ($map) = @_; 2023 my ($map) = @_;
1494 2024
2025 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2026 if $Coro::current == $Coro::main;
2027
1495 cf::sync_job { $map->load }; 2028 cf::sync_job { $map->load };
1496} 2029}
1497 2030
1498our %MAP_PREFETCH; 2031our %MAP_PREFETCH;
1499our $MAP_PREFETCHER = undef; 2032our $MAP_PREFETCHER = undef;
1500 2033
1501sub find_async { 2034sub find_async {
1502 my ($path, $origin) = @_; 2035 my ($path, $origin, $load) = @_;
1503 2036
1504 $path = normalise $path, $origin && $origin->{path}; 2037 $path = normalise $path, $origin && $origin->{path};
1505 2038
1506 if (my $map = $cf::MAP{$path}) { 2039 if (my $map = $cf::MAP{$path}) {
1507 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2040 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1508 } 2041 }
1509 2042
1510 undef $MAP_PREFETCH{$path}; 2043 $MAP_PREFETCH{$path} |= $load;
2044
1511 $MAP_PREFETCHER ||= cf::async { 2045 $MAP_PREFETCHER ||= cf::async {
2046 $Coro::current->{desc} = "map prefetcher";
2047
1512 while (%MAP_PREFETCH) { 2048 while (%MAP_PREFETCH) {
1513 for my $path (keys %MAP_PREFETCH) { 2049 while (my ($k, $v) = each %MAP_PREFETCH) {
1514 my $map = find $path 2050 if (my $map = find $k) {
1515 or next;
1516 $map->load; 2051 $map->load if $v;
2052 }
1517 2053
1518 delete $MAP_PREFETCH{$path}; 2054 delete $MAP_PREFETCH{$k};
1519 } 2055 }
1520 } 2056 }
1521 undef $MAP_PREFETCHER; 2057 undef $MAP_PREFETCHER;
1522 }; 2058 };
1523 $MAP_PREFETCHER->prio (6); 2059 $MAP_PREFETCHER->prio (6);
… …
1526} 2062}
1527 2063
1528sub save { 2064sub save {
1529 my ($self) = @_; 2065 my ($self) = @_;
1530 2066
1531 my $lock = cf::lock_acquire "map_data:" . $self->path; 2067 my $lock = cf::lock_acquire "map_data:$self->{path}";
1532 2068
1533 $self->{last_save} = $cf::RUNTIME; 2069 $self->{last_save} = $cf::RUNTIME;
1534 2070
1535 return unless $self->dirty; 2071 return unless $self->dirty;
1536 2072
… …
1542 return if $self->{deny_save}; 2078 return if $self->{deny_save};
1543 2079
1544 local $self->{last_access} = $self->last_access;#d# 2080 local $self->{last_access} = $self->last_access;#d#
1545 2081
1546 cf::async { 2082 cf::async {
2083 $Coro::current->{desc} = "map player save";
1547 $_->contr->save for $self->players; 2084 $_->contr->save for $self->players;
1548 }; 2085 };
1549 2086
1550 if ($uniq) { 2087 if ($uniq) {
1551 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2088 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1559 my ($self) = @_; 2096 my ($self) = @_;
1560 2097
1561 # save first because save cedes 2098 # save first because save cedes
1562 $self->save; 2099 $self->save;
1563 2100
1564 my $lock = cf::lock_acquire "map_data:" . $self->path; 2101 my $lock = cf::lock_acquire "map_data:$self->{path}";
1565 2102
1566 return if $self->players; 2103 return if $self->players;
1567 return if $self->in_memory != cf::MAP_IN_MEMORY; 2104 return if $self->in_memory != cf::MAP_IN_MEMORY;
1568 return if $self->{deny_save}; 2105 return if $self->{deny_save};
1569 2106
2107 $self->in_memory (cf::MAP_SWAPPED);
2108
2109 $self->deactivate;
2110 $_->clear_links_to ($self) for values %cf::MAP;
1570 $self->clear; 2111 $self->clear;
1571 $self->in_memory (cf::MAP_SWAPPED);
1572} 2112}
1573 2113
1574sub reset_at { 2114sub reset_at {
1575 my ($self) = @_; 2115 my ($self) = @_;
1576 2116
1577 # TODO: safety, remove and allow resettable per-player maps 2117 # 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}; 2118 return 1e99 if $self->{deny_reset};
1580 2119
1581 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2120 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1582 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2121 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1583 2122
… …
1594 my ($self) = @_; 2133 my ($self) = @_;
1595 2134
1596 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2135 my $lock = cf::lock_acquire "map_data:$self->{path}";
1597 2136
1598 return if $self->players; 2137 return if $self->players;
1599 return if $self->isa ("ext::map_per_player");#d#
1600 2138
1601 warn "resetting map ", $self->path;#d# 2139 warn "resetting map ", $self->path;
2140
2141 $self->in_memory (cf::MAP_SWAPPED);
2142
2143 # need to save uniques path
2144 unless ($self->{deny_save}) {
2145 my $uniq = $self->uniq_path; utf8::encode $uniq;
2146
2147 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2148 if $uniq;
2149 }
1602 2150
1603 delete $cf::MAP{$self->path}; 2151 delete $cf::MAP{$self->path};
1604 2152
1605 $self->in_memory (cf::MAP_SWAPPED); 2153 $self->deactivate;
2154 $_->clear_links_to ($self) for values %cf::MAP;
1606 $self->clear; 2155 $self->clear;
1607
1608 $_->clear_links_to ($self) for values %cf::MAP;
1609 2156
1610 $self->unlink_save; 2157 $self->unlink_save;
1611 $self->destroy; 2158 $self->destroy;
1612} 2159}
1613 2160
1614my $nuke_counter = "aaaa"; 2161my $nuke_counter = "aaaa";
1615 2162
1616sub nuke { 2163sub nuke {
1617 my ($self) = @_; 2164 my ($self) = @_;
1618 2165
2166 {
2167 my $lock = cf::lock_acquire "map_data:$self->{path}";
2168
1619 delete $cf::MAP{$self->path}; 2169 delete $cf::MAP{$self->path};
1620 2170
1621 $self->unlink_save; 2171 $self->unlink_save;
1622 2172
1623 bless $self, "cf::map"; 2173 bless $self, "cf::map";
1624 delete $self->{deny_reset}; 2174 delete $self->{deny_reset};
1625 $self->{deny_save} = 1; 2175 $self->{deny_save} = 1;
1626 $self->reset_timeout (1); 2176 $self->reset_timeout (1);
1627 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2177 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1628 2178
1629 $cf::MAP{$self->path} = $self; 2179 $cf::MAP{$self->path} = $self;
2180 }
1630 2181
1631 $self->reset; # polite request, might not happen 2182 $self->reset; # polite request, might not happen
2183}
2184
2185=item $maps = cf::map::tmp_maps
2186
2187Returns an arrayref with all map paths of currently instantiated and saved
2188maps. May block.
2189
2190=cut
2191
2192sub tmp_maps() {
2193 [
2194 map {
2195 utf8::decode $_;
2196 /\.map$/
2197 ? normalise $_
2198 : ()
2199 } @{ aio_readdir $TMPDIR or [] }
2200 ]
2201}
2202
2203=item $maps = cf::map::random_maps
2204
2205Returns an arrayref with all map paths of currently instantiated and saved
2206random maps. May block.
2207
2208=cut
2209
2210sub random_maps() {
2211 [
2212 map {
2213 utf8::decode $_;
2214 /\.map$/
2215 ? normalise "?random/$_"
2216 : ()
2217 } @{ aio_readdir $RANDOMDIR or [] }
2218 ]
1632} 2219}
1633 2220
1634=item cf::map::unique_maps 2221=item cf::map::unique_maps
1635 2222
1636Returns an arrayref of paths of all shared maps that have 2223Returns an arrayref of paths of all shared maps that have
1637instantiated unique items. May block. 2224instantiated unique items. May block.
1638 2225
1639=cut 2226=cut
1640 2227
1641sub unique_maps() { 2228sub unique_maps() {
1642 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2229 [
1643 or return; 2230 map {
1644
1645 my @paths;
1646
1647 for (@$files) {
1648 utf8::decode $_; 2231 utf8::decode $_;
1649 next if /\.pst$/; 2232 /\.map$/
1650 next unless /^$PATH_SEP/o; 2233 ? normalise $_
1651 2234 : ()
1652 push @paths, cf::map::normalise $_; 2235 } @{ aio_readdir $UNIQUEDIR or [] }
1653 } 2236 ]
1654
1655 \@paths
1656} 2237}
1657 2238
1658package cf; 2239package cf;
1659 2240
1660=back 2241=back
… …
1678 map { $_, inv_recursive_ $_->inv } @_ 2259 map { $_, inv_recursive_ $_->inv } @_
1679} 2260}
1680 2261
1681sub inv_recursive { 2262sub inv_recursive {
1682 inv_recursive_ inv $_[0] 2263 inv_recursive_ inv $_[0]
2264}
2265
2266=item $ref = $ob->ref
2267
2268creates and returns a persistent reference to an objetc that can be stored as a string.
2269
2270=item $ob = cf::object::deref ($refstring)
2271
2272returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2273even if the object actually exists. May block.
2274
2275=cut
2276
2277sub deref {
2278 my ($ref) = @_;
2279
2280 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2281 my ($uuid, $name) = ($1, $2);
2282 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2283 or return;
2284 $pl->ob->uuid eq $uuid
2285 or return;
2286
2287 $pl->ob
2288 } else {
2289 warn "$ref: cannot resolve object reference\n";
2290 undef
2291 }
1683} 2292}
1684 2293
1685package cf; 2294package cf;
1686 2295
1687=back 2296=back
… …
1706 2315
1707 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2316 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1708 2317
1709 if ($self->{record_replies}) { 2318 if ($self->{record_replies}) {
1710 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2319 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2320
1711 } else { 2321 } else {
2322 my $pl = $self->contr;
2323
2324 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2325 my $dialog = $pl->{npc_dialog};
2326 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2327
2328 } else {
1712 $msg = $npc->name . " says: $msg" if $npc; 2329 $msg = $npc->name . " says: $msg" if $npc;
1713 $self->message ($msg, $flags); 2330 $self->message ($msg, $flags);
2331 }
1714 } 2332 }
2333}
2334
2335=item $object->send_msg ($channel, $msg, $color, [extra...])
2336
2337=cut
2338
2339sub cf::object::send_msg {
2340 my $pl = shift->contr
2341 or return;
2342 $pl->send_msg (@_);
1715} 2343}
1716 2344
1717=item $player_object->may ("access") 2345=item $player_object->may ("access")
1718 2346
1719Returns wether the given player is authorized to access resource "access" 2347Returns wether the given player is authorized to access resource "access"
… …
1766 $self->deactivate_recursive; 2394 $self->deactivate_recursive;
1767 2395
1768 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2396 return if UNIVERSAL::isa $self->map, "ext::map_link";
1769 2397
1770 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2398 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1771 if $self->map; 2399 if $self->map && $self->map->{path} ne "{link}";
1772 2400
1773 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2401 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1774} 2402}
1775 2403
1776sub cf::object::player::leave_link { 2404sub cf::object::player::leave_link {
1777 my ($self, $map, $x, $y) = @_; 2405 my ($self, $map, $x, $y) = @_;
2406
2407 return unless $self->contr->active;
1778 2408
1779 my $link_pos = delete $self->{_link_pos}; 2409 my $link_pos = delete $self->{_link_pos};
1780 2410
1781 unless ($map) { 2411 unless ($map) {
1782 # restore original map position 2412 # restore original map position
… …
1796 # use -1 or undef as default coordinates, not 0, 0 2426 # use -1 or undef as default coordinates, not 0, 0
1797 ($x, $y) = ($map->enter_x, $map->enter_y) 2427 ($x, $y) = ($map->enter_x, $map->enter_y)
1798 if $x <=0 && $y <= 0; 2428 if $x <=0 && $y <= 0;
1799 2429
1800 $map->load; 2430 $map->load;
1801 $map->load_diag; 2431 $map->load_neighbours;
1802 2432
1803 return unless $self->contr->active; 2433 return unless $self->contr->active;
1804 $self->activate_recursive; 2434 $self->activate_recursive;
2435
2436 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1805 $self->enter_map ($map, $x, $y); 2437 $self->enter_map ($map, $x, $y);
1806} 2438}
1807 2439
1808cf::player->attach ( 2440=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1809 on_logout => sub {
1810 my ($pl) = @_;
1811 2441
1812 # abort map switching before logout 2442Moves the player to the given map-path and coordinates by first freezing
1813 if ($pl->ob->{_link_pos}) { 2443her, loading and preparing them map, calling the provided $check callback
1814 cf::sync_job { 2444that has to return the map if sucecssful, and then unfreezes the player on
1815 $pl->ob->leave_link 2445the new (success) or old (failed) map position. In either case, $done will
1816 }; 2446be called at the end of this process.
1817 }
1818 },
1819 on_login => sub {
1820 my ($pl) = @_;
1821 2447
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 2448=cut
2449
2450our $GOTOGEN;
1843 2451
1844sub cf::object::player::goto { 2452sub cf::object::player::goto {
1845 my ($self, $path, $x, $y) = @_; 2453 my ($self, $path, $x, $y, $check, $done) = @_;
2454
2455 # do generation counting so two concurrent goto's will be executed in-order
2456 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1846 2457
1847 $self->enter_link; 2458 $self->enter_link;
1848 2459
1849 (async { 2460 (async {
2461 $Coro::current->{desc} = "player::goto $path $x $y";
2462
2463 # *tag paths override both path and x|y
2464 if ($path =~ /^\*(.*)$/) {
2465 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2466 my $ob = $obs[rand @obs];
2467
2468 # see if we actually can go there
2469 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2470 $ob = $obs[rand @obs];
2471 } else {
2472 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2473 }
2474 # else put us there anyways for now #d#
2475
2476 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2477 } else {
2478 ($path, $x, $y) = (undef, undef, undef);
2479 }
2480 }
2481
1850 my $map = eval { 2482 my $map = eval {
1851 my $map = cf::map::find $path; 2483 my $map = defined $path ? cf::map::find $path : undef;
2484
2485 if ($map) {
1852 $map = $map->customise_for ($self) if $map; 2486 $map = $map->customise_for ($self);
2487 $map = $check->($map) if $check && $map;
2488 } else {
2489 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2490 }
2491
1853 $map 2492 $map
2493 };
2494
2495 if ($@) {
2496 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2497 LOG llevError | logBacktrace, Carp::longmess $@;
1854 } or 2498 }
1855 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1856 2499
2500 if ($gen == $self->{_goto_generation}) {
2501 delete $self->{_goto_generation};
1857 $self->leave_link ($map, $x, $y); 2502 $self->leave_link ($map, $x, $y);
2503 }
2504
2505 $done->() if $done;
1858 })->prio (1); 2506 })->prio (1);
1859} 2507}
1860 2508
1861=item $player_object->enter_exit ($exit_object) 2509=item $player_object->enter_exit ($exit_object)
1862 2510
… …
1901 2549
1902 $rmp->{random_seed} ||= $exit->random_seed; 2550 $rmp->{random_seed} ||= $exit->random_seed;
1903 2551
1904 my $data = cf::to_json $rmp; 2552 my $data = cf::to_json $rmp;
1905 my $md5 = Digest::MD5::md5_hex $data; 2553 my $md5 = Digest::MD5::md5_hex $data;
1906 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2554 my $meta = "$RANDOMDIR/$md5.meta";
1907 2555
1908 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2556 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1909 aio_write $fh, 0, (length $data), $data, 0; 2557 aio_write $fh, 0, (length $data), $data, 0;
1910 undef $fh; 2558 undef $fh;
1911 aio_rename "$meta~", $meta; 2559 aio_rename "$meta~", $meta;
… …
1920 2568
1921 return unless $self->type == cf::PLAYER; 2569 return unless $self->type == cf::PLAYER;
1922 2570
1923 if ($exit->slaying eq "/!") { 2571 if ($exit->slaying eq "/!") {
1924 #TODO: this should de-fi-ni-te-ly not be a sync-job 2572 #TODO: this should de-fi-ni-te-ly not be a sync-job
2573 # the problem is that $exit might not survive long enough
2574 # so it needs to be done right now, right here
1925 cf::sync_job { prepare_random_map $exit }; 2575 cf::sync_job { prepare_random_map $exit };
1926 } 2576 }
1927 2577
1928 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2578 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1929 my $hp = $exit->stats->hp; 2579 my $hp = $exit->stats->hp;
1930 my $sp = $exit->stats->sp; 2580 my $sp = $exit->stats->sp;
1931 2581
1932 $self->enter_link; 2582 $self->enter_link;
1933 2583
2584 # if exit is damned, update players death & WoR home-position
2585 $self->contr->savebed ($slaying, $hp, $sp)
2586 if $exit->flag (FLAG_DAMNED);
2587
1934 (async { 2588 (async {
2589 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2590
1935 $self->deactivate_recursive; # just to be sure 2591 $self->deactivate_recursive; # just to be sure
1936 unless (eval { 2592 unless (eval {
1937 $self->goto ($slaying, $hp, $sp); 2593 $self->goto ($slaying, $hp, $sp);
1938 2594
1939 1; 2595 1;
1940 }) { 2596 }) {
1941 $self->message ("Something went wrong deep within the crossfire server. " 2597 $self->message ("Something went wrong deep within the crossfire server. "
1942 . "I'll try to bring you back to the map you were before. " 2598 . "I'll try to bring you back to the map you were before. "
1943 . "Please report this to the dungeon master!", 2599 . "Please report this to the dungeon master!",
1944 cf::NDI_UNIQUE | cf::NDI_RED); 2600 cf::NDI_UNIQUE | cf::NDI_RED);
1945 2601
1946 warn "ERROR in enter_exit: $@"; 2602 warn "ERROR in enter_exit: $@";
1947 $self->leave_link; 2603 $self->leave_link;
1948 } 2604 }
1949 })->prio (1); 2605 })->prio (1);
… …
1962 2618
1963sub cf::client::send_drawinfo { 2619sub cf::client::send_drawinfo {
1964 my ($self, $text, $flags) = @_; 2620 my ($self, $text, $flags) = @_;
1965 2621
1966 utf8::encode $text; 2622 utf8::encode $text;
1967 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2623 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1968} 2624}
1969 2625
2626=item $client->send_msg ($channel, $msg, $color, [extra...])
2627
2628Send a drawinfo or msg packet to the client, formatting the msg for the
2629client if neccessary. C<$type> should be a string identifying the type of
2630the message, with C<log> being the default. If C<$color> is negative, suppress
2631the message unless the client supports the msg packet.
2632
2633=cut
2634
2635our %CHANNEL = (
2636 "c/identify" => {
2637 id => "infobox",
2638 title => "Identify",
2639 reply => undef,
2640 tooltip => "Items recently identified",
2641 },
2642 "c/examine" => {
2643 id => "infobox",
2644 title => "Examine",
2645 reply => undef,
2646 tooltip => "Signs and other items you examined",
2647 },
2648 "c/lookat" => {
2649 id => "infobox",
2650 title => "Look",
2651 reply => undef,
2652 tooltip => "What you saw there",
2653 },
2654);
2655
2656sub cf::client::send_msg {
2657 my ($self, $channel, $msg, $color, @extra) = @_;
2658
2659 $msg = $self->pl->expand_cfpod ($msg);
2660
2661 $color &= cf::NDI_CLIENT_MASK; # just in case...
2662
2663 # check predefined channels, for the benefit of C
2664 if ($CHANNEL{$channel}) {
2665 $channel = $CHANNEL{$channel};
2666
2667 $self->ext_msg (channel_info => $channel)
2668 if $self->can_msg;
2669
2670 $channel = $channel->{id};
2671
2672 } elsif (ref $channel) {
2673 # send meta info to client, if not yet sent
2674 unless (exists $self->{channel}{$channel->{id}}) {
2675 $self->{channel}{$channel->{id}} = $channel;
2676 $self->ext_msg (channel_info => $channel)
2677 if $self->can_msg;
2678 }
2679
2680 $channel = $channel->{id};
2681 }
2682
2683 return unless @extra || length $msg;
2684
2685 if ($self->can_msg) {
2686 # default colour, mask it out
2687 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2688 if $color & cf::NDI_DEF;
2689
2690 $self->send_packet ("msg " . $self->{json_coder}->encode (
2691 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2692 } else {
2693 if ($color >= 0) {
2694 # replace some tags by gcfclient-compatible ones
2695 for ($msg) {
2696 1 while
2697 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2698 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2699 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2700 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2701 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2702 }
2703
2704 $color &= cf::NDI_COLOR_MASK;
2705
2706 utf8::encode $msg;
2707
2708 if (0 && $msg =~ /\[/) {
2709 # COMMAND/INFO
2710 $self->send_packet ("drawextinfo $color 10 8 $msg")
2711 } else {
2712 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2713 $self->send_packet ("drawinfo $color $msg")
2714 }
2715 }
2716 }
2717}
2718
2719=item $client->ext_msg ($type, @msg)
2720
2721Sends an ext event to the client.
2722
2723=cut
2724
2725sub cf::client::ext_msg($$@) {
2726 my ($self, $type, @msg) = @_;
2727
2728 if ($self->extcmd == 2) {
2729 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2730 } elsif ($self->extcmd == 1) { # TODO: remove
2731 push @msg, msgtype => "event_$type";
2732 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2733 }
2734}
2735
2736=item $client->ext_reply ($msgid, @msg)
2737
2738Sends an ext reply to the client.
2739
2740=cut
2741
2742sub cf::client::ext_reply($$@) {
2743 my ($self, $id, @msg) = @_;
2744
2745 if ($self->extcmd == 2) {
2746 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2747 } elsif ($self->extcmd == 1) {
2748 #TODO: version 1, remove
2749 unshift @msg, msgtype => "reply", msgid => $id;
2750 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2751 }
2752}
1970 2753
1971=item $success = $client->query ($flags, "text", \&cb) 2754=item $success = $client->query ($flags, "text", \&cb)
1972 2755
1973Queues a query to the client, calling the given callback with 2756Queues a query to the client, calling the given callback with
1974the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2757the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1975C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2758C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1976 2759
1977Queries can fail, so check the return code. Or don't, as queries will become 2760Queries can fail, so check the return code. Or don't, as queries will
1978reliable at some point in the future. 2761become reliable at some point in the future.
1979 2762
1980=cut 2763=cut
1981 2764
1982sub cf::client::query { 2765sub cf::client::query {
1983 my ($self, $flags, $text, $cb) = @_; 2766 my ($self, $flags, $text, $cb) = @_;
… …
1991 utf8::encode $text; 2774 utf8::encode $text;
1992 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2775 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1993 2776
1994 $self->send_packet ($self->{query_queue}[0][0]) 2777 $self->send_packet ($self->{query_queue}[0][0])
1995 if @{ $self->{query_queue} } == 1; 2778 if @{ $self->{query_queue} } == 1;
2779
2780 1
1996} 2781}
1997 2782
1998cf::client->attach ( 2783cf::client->attach (
2784 on_connect => sub {
2785 my ($ns) = @_;
2786
2787 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2788 },
1999 on_reply => sub { 2789 on_reply => sub {
2000 my ($ns, $msg) = @_; 2790 my ($ns, $msg) = @_;
2001 2791
2002 # this weird shuffling is so that direct followup queries 2792 # this weird shuffling is so that direct followup queries
2003 # get handled first 2793 # get handled first
… …
2015 } else { 2805 } else {
2016 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2806 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2017 } 2807 }
2018 } 2808 }
2019 }, 2809 },
2810 on_exticmd => sub {
2811 my ($ns, $buf) = @_;
2812
2813 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2814
2815 if (ref $msg) {
2816 my ($type, $reply, @payload) =
2817 "ARRAY" eq ref $msg
2818 ? @$msg
2819 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2820
2821 my @reply;
2822
2823 if (my $cb = $EXTICMD{$type}) {
2824 @reply = $cb->($ns, @payload);
2825 }
2826
2827 $ns->ext_reply ($reply, @reply)
2828 if $reply;
2829
2830 } else {
2831 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2832 }
2833
2834 cf::override;
2835 },
2020); 2836);
2021 2837
2022=item $client->async (\&cb) 2838=item $client->async (\&cb)
2023 2839
2024Create a new coroutine, running the specified callback. The coroutine will 2840Create a new coroutine, running the specified callback. The coroutine will
… …
2065our $safe = new Safe "safe"; 2881our $safe = new Safe "safe";
2066our $safe_hole = new Safe::Hole; 2882our $safe_hole = new Safe::Hole;
2067 2883
2068$SIG{FPE} = 'IGNORE'; 2884$SIG{FPE} = 'IGNORE';
2069 2885
2070$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2886$safe->permit_only (Opcode::opset qw(
2887 :base_core :base_mem :base_orig :base_math
2888 grepstart grepwhile mapstart mapwhile
2889 sort time
2890));
2071 2891
2072# here we export the classes and methods available to script code 2892# here we export the classes and methods available to script code
2073 2893
2074=pod 2894=pod
2075 2895
2076The following fucntions and emthods are available within a safe environment: 2896The following functions and methods are available within a safe environment:
2077 2897
2078 cf::object contr pay_amount pay_player map 2898 cf::object
2899 contr pay_amount pay_player map x y force_find force_add
2900 insert remove name archname title slaying race decrease_ob_nr
2901
2079 cf::object::player player 2902 cf::object::player
2080 cf::player peaceful 2903 player
2081 cf::map trigger 2904
2905 cf::player
2906 peaceful
2907
2908 cf::map
2909 trigger
2082 2910
2083=cut 2911=cut
2084 2912
2085for ( 2913for (
2086 ["cf::object" => qw(contr pay_amount pay_player map)], 2914 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2915 insert remove inv name archname title slaying race
2916 decrease_ob_nr)],
2087 ["cf::object::player" => qw(player)], 2917 ["cf::object::player" => qw(player)],
2088 ["cf::player" => qw(peaceful)], 2918 ["cf::player" => qw(peaceful)],
2089 ["cf::map" => qw(trigger)], 2919 ["cf::map" => qw(trigger)],
2090) { 2920) {
2091 no strict 'refs'; 2921 no strict 'refs';
… …
2162=back 2992=back
2163 2993
2164=cut 2994=cut
2165 2995
2166############################################################################# 2996#############################################################################
2997# the server's init and main functions
2167 2998
2168=head2 EXTENSION DATABASE SUPPORT 2999sub load_facedata($) {
3000 my ($path) = @_;
2169 3001
2170Crossfire maintains a very simple database for extension use. It can 3002 # HACK to clear player env face cache, we need some signal framework
2171currently store anything that can be serialised using Storable, which 3003 # for this (global event?)
2172excludes objects. 3004 %ext::player_env::MUSIC_FACE_CACHE = ();
2173 3005
2174The parameter C<$family> should best start with the name of the extension 3006 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2175using it, it should be unique.
2176 3007
2177=over 4 3008 warn "loading facedata from $path\n";
2178 3009
2179=item $hashref = cf::db_get $family 3010 my $facedata;
3011 0 < aio_load $path, $facedata
3012 or die "$path: $!";
2180 3013
2181Return a hashref for use by the extension C<$family>, which can be 3014 $facedata = Coro::Storable::thaw $facedata;
2182modified. After modifications, you have to call C<cf::db_dirty> or
2183C<cf::db_sync>.
2184 3015
2185=item $value = cf::db_get $family => $key 3016 $facedata->{version} == 2
3017 or cf::cleanup "$path: version mismatch, cannot proceed.";
2186 3018
2187Returns a single value from the database 3019 # patch in the exptable
2188 3020 $facedata->{resource}{"res/exp_table"} = {
2189=item cf::db_put $family => $hashref 3021 type => FT_RSRC,
2190 3022 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 } 3023 };
3024 cf::cede_to_tick;
2217 3025
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 } 3026 {
3027 my $faces = $facedata->{faceinfo};
2229 3028
2230 my $dirty; 3029 while (my ($face, $info) = each %$faces) {
3030 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3031 cf::face::set_visibility $idx, $info->{visibility};
3032 cf::face::set_magicmap $idx, $info->{magicmap};
3033 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
3034 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2231 3035
2232 sub db_sync() { 3036 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 }, 3037 }
2271 );
2272}
2273 3038
2274############################################################################# 3039 while (my ($face, $info) = each %$faces) {
2275# the server's main() 3040 next unless $info->{smooth};
3041 my $idx = cf::face::find $face
3042 or next;
3043 if (my $smooth = cf::face::find $info->{smooth}) {
3044 cf::face::set_smooth $idx, $smooth;
3045 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3046 } else {
3047 warn "smooth face '$info->{smooth}' not found for face '$face'";
3048 }
2276 3049
2277sub cfg_load { 3050 cf::cede_to_tick;
3051 }
3052 }
3053
3054 {
3055 my $anims = $facedata->{animinfo};
3056
3057 while (my ($anim, $info) = each %$anims) {
3058 cf::anim::set $anim, $info->{frames}, $info->{facings};
3059 cf::cede_to_tick;
3060 }
3061
3062 cf::anim::invalidate_all; # d'oh
3063 }
3064
3065 {
3066 # TODO: for gcfclient pleasure, we should give resources
3067 # that gcfclient doesn't grok a >10000 face index.
3068 my $res = $facedata->{resource};
3069
3070 my $soundconf = delete $res->{"res/sound.conf"};
3071
3072 while (my ($name, $info) = each %$res) {
3073 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3074 my $data;
3075
3076 if ($info->{type} & 1) {
3077 # prepend meta info
3078
3079 my $meta = $enc->encode ({
3080 name => $name,
3081 %{ $info->{meta} || {} },
3082 });
3083
3084 $data = pack "(w/a*)*", $meta, $info->{data};
3085 } else {
3086 $data = $info->{data};
3087 }
3088
3089 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3090 cf::face::set_type $idx, $info->{type};
3091
3092 cf::cede_to_tick;
3093 }
3094
3095 if ($soundconf) {
3096 $soundconf = $enc->decode (delete $soundconf->{data});
3097
3098 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3099 my $sound = $soundconf->{compat}[$_]
3100 or next;
3101
3102 my $face = cf::face::find "sound/$sound->[1]";
3103 cf::sound::set $sound->[0] => $face;
3104 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3105 }
3106
3107 while (my ($k, $v) = each %{$soundconf->{event}}) {
3108 my $face = cf::face::find "sound/$v";
3109 cf::sound::set $k => $face;
3110 }
3111 }
3112 }
3113
3114 1
3115}
3116
3117register_exticmd fx_want => sub {
3118 my ($ns, $want) = @_;
3119
3120 while (my ($k, $v) = each %$want) {
3121 $ns->fx_want ($k, $v);
3122 }
3123};
3124
3125sub reload_regions {
3126 # HACK to clear player env face cache, we need some signal framework
3127 # for this (global event?)
3128 %ext::player_env::MUSIC_FACE_CACHE = ();
3129
3130 load_resource_file "$MAPDIR/regions"
3131 or die "unable to load regions file\n";
3132
3133 for (cf::region::list) {
3134 $_->{match} = qr/$_->{match}/
3135 if exists $_->{match};
3136 }
3137}
3138
3139sub reload_facedata {
3140 load_facedata "$DATADIR/facedata"
3141 or die "unable to load facedata\n";
3142}
3143
3144sub reload_archetypes {
3145 load_resource_file "$DATADIR/archetypes"
3146 or die "unable to load archetypes\n";
3147 #d# NEED to laod twice to resolve forward references
3148 # this really needs to be done in an extra post-pass
3149 # (which needs to be synchronous, so solve it differently)
3150 load_resource_file "$DATADIR/archetypes"
3151 or die "unable to load archetypes\n";
3152}
3153
3154sub reload_treasures {
3155 load_resource_file "$DATADIR/treasures"
3156 or die "unable to load treasurelists\n";
3157}
3158
3159sub reload_resources {
3160 warn "reloading resource files...\n";
3161
3162 reload_regions;
3163 reload_facedata;
3164 #reload_archetypes;#d#
3165 reload_archetypes;
3166 reload_treasures;
3167
3168 warn "finished reloading resource files\n";
3169}
3170
3171sub init {
3172 reload_resources;
3173}
3174
3175sub reload_config {
2278 open my $fh, "<:utf8", cf::confdir . "/config" 3176 open my $fh, "<:utf8", "$CONFDIR/config"
2279 or return; 3177 or return;
2280 3178
2281 local $/; 3179 local $/;
2282 *CFG = YAML::Syck::Load <$fh>; 3180 *CFG = YAML::Syck::Load <$fh>;
2283 3181
… …
2298sub main { 3196sub main {
2299 # we must not ever block the main coroutine 3197 # we must not ever block the main coroutine
2300 local $Coro::idle = sub { 3198 local $Coro::idle = sub {
2301 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3199 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2302 (async { 3200 (async {
3201 $Coro::current->{desc} = "IDLE BUG HANDLER";
2303 Event::one_event; 3202 Event::one_event;
2304 })->prio (Coro::PRIO_MAX); 3203 })->prio (Coro::PRIO_MAX);
2305 }; 3204 };
2306 3205
2307 cfg_load; 3206 reload_config;
2308 db_load; 3207 db_init;
2309 load_extensions; 3208 load_extensions;
2310 3209
2311 $TICK_WATCHER->start; 3210 $TICK_WATCHER->start;
2312 Event::loop; 3211 Event::loop;
2313} 3212}
… …
2328 }, 3227 },
2329 ); 3228 );
2330 } 3229 }
2331} 3230}
2332 3231
3232sub write_runtime {
3233 my $runtime = "$LOCALDIR/runtime";
3234
3235 # first touch the runtime file to show we are still running:
3236 # the fsync below can take a very very long time.
3237
3238 IO::AIO::aio_utime $runtime, undef, undef;
3239
3240 my $guard = cf::lock_acquire "write_runtime";
3241
3242 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3243 or return;
3244
3245 my $value = $cf::RUNTIME + 90 + 10;
3246 # 10 is the runtime save interval, for a monotonic clock
3247 # 60 allows for the watchdog to kill the server.
3248
3249 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3250 and return;
3251
3252 # always fsync - this file is important
3253 aio_fsync $fh
3254 and return;
3255
3256 # touch it again to show we are up-to-date
3257 aio_utime $fh, undef, undef;
3258
3259 close $fh
3260 or return;
3261
3262 aio_rename "$runtime~", $runtime
3263 and return;
3264
3265 warn "runtime file written.\n";
3266
3267 1
3268}
3269
2333sub emergency_save() { 3270sub emergency_save() {
2334 my $freeze_guard = cf::freeze_mainloop; 3271 my $freeze_guard = cf::freeze_mainloop;
2335 3272
2336 warn "enter emergency perl save\n"; 3273 warn "enter emergency perl save\n";
2337 3274
… …
2352 my $map = $cf::MAP{$path} or next; 3289 my $map = $cf::MAP{$path} or next;
2353 $map->valid or next; 3290 $map->valid or next;
2354 $map->save; 3291 $map->save;
2355 } 3292 }
2356 warn "end emergency map save\n"; 3293 warn "end emergency map save\n";
3294
3295 warn "begin emergency database checkpoint\n";
3296 BDB::db_env_txn_checkpoint $DB_ENV;
3297 warn "end emergency database checkpoint\n";
2357 }; 3298 };
2358 3299
2359 warn "leave emergency perl save\n"; 3300 warn "leave emergency perl save\n";
2360} 3301}
2361 3302
3303sub post_cleanup {
3304 my ($make_core) = @_;
3305
3306 warn Carp::longmess "post_cleanup backtrace"
3307 if $make_core;
3308}
3309
2362sub reload() { 3310sub do_reload_perl() {
2363 # can/must only be called in main 3311 # can/must only be called in main
2364 if ($Coro::current != $Coro::main) { 3312 if ($Coro::current != $Coro::main) {
2365 warn "can only reload from main coroutine"; 3313 warn "can only reload from main coroutine";
2366 return; 3314 return;
2367 } 3315 }
2368 3316
2369 warn "reloading..."; 3317 warn "reloading...";
2370 3318
2371 warn "cancelling server ticker"; 3319 warn "entering sync_job";
2372 $TICK_WATCHER->cancel;
2373 3320
3321 cf::sync_job {
3322 cf::write_runtime; # external watchdog should not bark
2374 cf::emergency_save; 3323 cf::emergency_save;
3324 cf::write_runtime; # external watchdog should not bark
2375 3325
2376 eval { 3326 warn "syncing database to disk";
3327 BDB::db_env_txn_checkpoint $DB_ENV;
3328
2377 # if anything goes wrong in here, we should simply crash as we already saved 3329 # 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 3330
2382 warn "cancelling all WF_AUTOCANCEL watchers"; 3331 warn "cancelling all WF_AUTOCANCEL watchers";
2383 for (Event::all_watchers) { 3332 for (Event::all_watchers) {
2384 $_->cancel if $_->data & WF_AUTOCANCEL; 3333 $_->cancel if $_->data & WF_AUTOCANCEL;
2385 } 3334 }
2386 3335
2387 warn "flushing outstanding aio requests"; 3336 warn "flushing outstanding aio requests";
2388 for (;;) { 3337 for (;;) {
3338 BDB::flush;
2389 IO::AIO::flush; 3339 IO::AIO::flush;
2390 Coro::cede; 3340 Coro::cede;
2391 last unless IO::AIO::nreqs; 3341 last unless IO::AIO::nreqs || BDB::nreqs;
2392 warn "iterate..."; 3342 warn "iterate...";
2393 } 3343 }
3344
3345 ++$RELOAD;
2394 3346
2395 warn "cancelling all extension coros"; 3347 warn "cancelling all extension coros";
2396 $_->cancel for values %EXT_CORO; 3348 $_->cancel for values %EXT_CORO;
2397 %EXT_CORO = (); 3349 %EXT_CORO = ();
2398 3350
2399 warn "removing commands"; 3351 warn "removing commands";
2400 %COMMAND = (); 3352 %COMMAND = ();
2401 3353
2402 warn "removing ext commands"; 3354 warn "removing ext/exti commands";
2403 %EXTCMD = (); 3355 %EXTCMD = ();
3356 %EXTICMD = ();
2404 3357
2405 warn "unloading/nuking all extensions"; 3358 warn "unloading/nuking all extensions";
2406 for my $pkg (@EXTS) { 3359 for my $pkg (@EXTS) {
2407 warn "... unloading $pkg"; 3360 warn "... unloading $pkg";
2408 3361
… …
2438 Symbol::delete_package "safe::$_" 3391 Symbol::delete_package "safe::$_"
2439 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3392 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2440 3393
2441 warn "unloading cf.pm \"a bit\""; 3394 warn "unloading cf.pm \"a bit\"";
2442 delete $INC{"cf.pm"}; 3395 delete $INC{"cf.pm"};
3396 delete $INC{"cf/pod.pm"};
2443 3397
2444 # don't, removes xs symbols, too, 3398 # don't, removes xs symbols, too,
2445 # and global variables created in xs 3399 # and global variables created in xs
2446 #Symbol::delete_package __PACKAGE__; 3400 #Symbol::delete_package __PACKAGE__;
2447 3401
… …
2450 warn "reloading cf.pm"; 3404 warn "reloading cf.pm";
2451 require cf; 3405 require cf;
2452 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3406 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2453 3407
2454 warn "loading config and database again"; 3408 warn "loading config and database again";
2455 cf::cfg_load; 3409 cf::reload_config;
2456 cf::db_load;
2457 3410
2458 warn "loading extensions"; 3411 warn "loading extensions";
2459 cf::load_extensions; 3412 cf::load_extensions;
2460 3413
2461 warn "reattaching attachments to objects/players"; 3414 warn "reattaching attachments to objects/players";
2462 _global_reattach; 3415 _global_reattach; # objects, sockets
2463 warn "reattaching attachments to maps"; 3416 warn "reattaching attachments to maps";
2464 reattach $_ for values %MAP; 3417 reattach $_ for values %MAP;
3418 warn "reattaching attachments to players";
3419 reattach $_ for values %PLAYER;
2465 3420
2466 warn "restarting server ticker"; 3421 warn "leaving sync_job";
2467 3422
2468 $TICK_WATCHER->start; 3423 1
2469 }; 3424 } or do {
2470
2471 if ($@) {
2472 warn $@; 3425 warn $@;
2473 warn "error while reloading, exiting."; 3426 warn "error while reloading, exiting.";
2474 exit 1; 3427 exit 1;
2475 } 3428 };
2476 3429
2477 warn "reloaded"; 3430 warn "reloaded";
2478}; 3431};
2479 3432
2480our $RELOAD_WATCHER; # used only during reload 3433our $RELOAD_WATCHER; # used only during reload
2481 3434
3435sub reload_perl() {
3436 # doing reload synchronously and two reloads happen back-to-back,
3437 # coro crashes during coro_state_free->destroy here.
3438
3439 $RELOAD_WATCHER ||= Event->timer (
3440 reentrant => 0,
3441 after => 0,
3442 data => WF_AUTOCANCEL,
3443 cb => sub {
3444 do_reload_perl;
3445 undef $RELOAD_WATCHER;
3446 },
3447 );
3448}
3449
2482register_command "reload" => sub { 3450register_command "reload" => sub {
2483 my ($who, $arg) = @_; 3451 my ($who, $arg) = @_;
2484 3452
2485 if ($who->flag (FLAG_WIZ)) { 3453 if ($who->flag (FLAG_WIZ)) {
2486 $who->message ("reloading server."); 3454 $who->message ("reloading server.");
2487 3455 async {
2488 # doing reload synchronously and two reloads happen back-to-back, 3456 $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; 3457 reload_perl;
2497 undef $RELOAD_WATCHER;
2498 },
2499 ); 3458 };
2500 } 3459 }
2501}; 3460};
2502 3461
2503unshift @INC, $LIBDIR; 3462unshift @INC, $LIBDIR;
2504 3463
2505my $bug_warning = 0; 3464my $bug_warning = 0;
3465
3466our @WAIT_FOR_TICK;
3467our @WAIT_FOR_TICK_BEGIN;
3468
3469sub wait_for_tick {
3470 return unless $TICK_WATCHER->is_active;
3471 return if $Coro::current == $Coro::main;
3472
3473 my $signal = new Coro::Signal;
3474 push @WAIT_FOR_TICK, $signal;
3475 $signal->wait;
3476}
3477
3478sub wait_for_tick_begin {
3479 return unless $TICK_WATCHER->is_active;
3480 return if $Coro::current == $Coro::main;
3481
3482 my $signal = new Coro::Signal;
3483 push @WAIT_FOR_TICK_BEGIN, $signal;
3484 $signal->wait;
3485}
2506 3486
2507$TICK_WATCHER = Event->timer ( 3487$TICK_WATCHER = Event->timer (
2508 reentrant => 0, 3488 reentrant => 0,
2509 parked => 1, 3489 parked => 1,
2510 prio => 0, 3490 prio => 0,
… …
2515 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3495 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2516 unless ++$bug_warning > 10; 3496 unless ++$bug_warning > 10;
2517 return; 3497 return;
2518 } 3498 }
2519 3499
2520 $NOW = Event::time; 3500 $NOW = $tick_start = Event::time;
2521 3501
2522 cf::server_tick; # one server iteration 3502 cf::server_tick; # one server iteration
3503
2523 $RUNTIME += $TICK; 3504 $RUNTIME += $TICK;
2524 $NEXT_TICK += $TICK; 3505 $NEXT_TICK += $TICK;
2525 3506
2526 $WAIT_FOR_TICK->broadcast; 3507 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2527 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 3508 $NEXT_RUNTIME_WRITE = $NOW + 10;
2528 3509 Coro::async_pool {
2529 Event::sweep; 3510 $Coro::current->{desc} = "runtime saver";
2530 Coro::cede_notself; 3511 write_runtime
3512 or warn "ERROR: unable to write runtime file: $!";
3513 };
2531 3514 }
2532# my $AFTER = Event::time; 3515
2533# warn $AFTER - $NOW;#d# 3516 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3517 $sig->send;
3518 }
3519 while (my $sig = shift @WAIT_FOR_TICK) {
3520 $sig->send;
3521 }
3522
3523 $NOW = Event::time;
2534 3524
2535 # if we are delayed by four ticks or more, skip them all 3525 # if we are delayed by four ticks or more, skip them all
2536 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3526 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2537 3527
2538 $TICK_WATCHER->at ($NEXT_TICK); 3528 $TICK_WATCHER->at ($NEXT_TICK);
2539 $TICK_WATCHER->start; 3529 $TICK_WATCHER->start;
3530
3531 $LOAD = ($NOW - $tick_start) / $TICK;
3532 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3533
3534 _post_tick;
2540 }, 3535 },
2541); 3536);
2542 3537
3538{
3539 BDB::min_parallel 8;
3540 BDB::max_poll_time $TICK * 0.1;
3541 $BDB_POLL_WATCHER = Event->io (
3542 reentrant => 0,
3543 fd => BDB::poll_fileno,
3544 poll => 'r',
3545 prio => 0,
3546 data => WF_AUTOCANCEL,
3547 cb => \&BDB::poll_cb,
3548 );
3549
3550 BDB::set_sync_prepare {
3551 my $status;
3552 my $current = $Coro::current;
3553 (
3554 sub {
3555 $status = $!;
3556 $current->ready; undef $current;
3557 },
3558 sub {
3559 Coro::schedule while defined $current;
3560 $! = $status;
3561 },
3562 )
3563 };
3564
3565 unless ($DB_ENV) {
3566 $DB_ENV = BDB::db_env_create;
3567 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3568 | BDB::LOG_AUTOREMOVE, 1);
3569 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3570 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3571
3572 cf::sync_job {
3573 eval {
3574 BDB::db_env_open
3575 $DB_ENV,
3576 $BDBDIR,
3577 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3578 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3579 0666;
3580
3581 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3582 };
3583
3584 cf::cleanup "db_env_open(db): $@" if $@;
3585 };
3586 }
3587
3588 $BDB_DEADLOCK_WATCHER = Event->timer (
3589 after => 3,
3590 interval => 1,
3591 hard => 1,
3592 prio => 0,
3593 data => WF_AUTOCANCEL,
3594 cb => sub {
3595 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3596 },
3597 );
3598 $BDB_CHECKPOINT_WATCHER = Event->timer (
3599 after => 11,
3600 interval => 60,
3601 hard => 1,
3602 prio => 0,
3603 data => WF_AUTOCANCEL,
3604 cb => sub {
3605 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3606 },
3607 );
3608 $BDB_TRICKLE_WATCHER = Event->timer (
3609 after => 5,
3610 interval => 10,
3611 hard => 1,
3612 prio => 0,
3613 data => WF_AUTOCANCEL,
3614 cb => sub {
3615 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3616 },
3617 );
3618}
3619
3620{
3621 IO::AIO::min_parallel 8;
3622
3623 undef $Coro::AIO::WATCHER;
2543IO::AIO::max_poll_time $TICK * 0.1; 3624 IO::AIO::max_poll_time $TICK * 0.1;
2544
2545undef $Coro::AIO::WATCHER;
2546$AIO_POLL_WATCHER = Event->io ( 3625 $AIO_POLL_WATCHER = Event->io (
2547 reentrant => 0, 3626 reentrant => 0,
3627 data => WF_AUTOCANCEL,
2548 fd => IO::AIO::poll_fileno, 3628 fd => IO::AIO::poll_fileno,
2549 poll => 'r', 3629 poll => 'r',
2550 prio => 6, 3630 prio => 0,
2551 data => WF_AUTOCANCEL,
2552 cb => \&IO::AIO::poll_cb, 3631 cb => \&IO::AIO::poll_cb,
2553); 3632 );
3633}
2554 3634
2555$WRITE_RUNTIME_WATCHER = Event->timer ( 3635my $_log_backtrace;
2556 reentrant => 0, 3636
2557 data => WF_AUTOCANCEL, 3637sub _log_backtrace {
2558 after => 1, 3638 my ($msg, @addr) = @_;
2559 interval => 10, 3639
2560 prio => 6, # keep it lowest so it acts like a watchdog 3640 $msg =~ s/\n//;
2561 cb => Coro::unblock_sub { 3641
2562 write_runtime 3642 # limit the # of concurrent backtraces
2563 or warn "ERROR: unable to write runtime file: $!"; 3643 if ($_log_backtrace < 2) {
3644 ++$_log_backtrace;
3645 async {
3646 $Coro::current->{desc} = "abt $msg";
3647
3648 my @bt = fork_call {
3649 @addr = map { sprintf "%x", $_ } @addr;
3650 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3651 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3652 or die "addr2line: $!";
3653
3654 my @funcs;
3655 my @res = <$fh>;
3656 chomp for @res;
3657 while (@res) {
3658 my ($func, $line) = splice @res, 0, 2, ();
3659 push @funcs, "[$func] $line";
3660 }
3661
3662 @funcs
3663 };
3664
3665 LOG llevInfo, "[ABT] $msg\n";
3666 LOG llevInfo, "[ABT] $_\n" for @bt;
3667 --$_log_backtrace;
3668 };
3669 } else {
3670 LOG llevInfo, "[ABT] $msg\n";
3671 LOG llevInfo, "[ABT] [suppressed]\n";
2564 }, 3672 }
2565); 3673}
3674
3675# load additional modules
3676use cf::pod;
2566 3677
2567END { cf::emergency_save } 3678END { cf::emergency_save }
2568 3679
25691 36801
2570 3681

Diff Legend

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