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.176 by root, Sun Jan 14 22:14:35 2007 UTC vs.
Revision 1.281 by root, Sat Jun 16 23:22:59 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.4 (); 15use Coro 3.61 ();
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;
19 24
25use BDB ();
20use Data::Dumper; 26use Data::Dumper;
21use Digest::MD5; 27use Digest::MD5;
22use Fcntl; 28use Fcntl;
29use YAML::Syck ();
23use IO::AIO 2.32 (); 30use IO::AIO 2.32 ();
24use YAML::Syck ();
25use Time::HiRes; 31use Time::HiRes;
32use Compress::LZF;
26 33
34# configure various modules to our taste
35#
36$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39
27use Event; $Event::Eval = 1; # no idea why this is required, but it is 40$Event::Eval = 1; # no idea why this is required, but it is
28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30 41
31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
32$YAML::Syck::ImplicitUnicode = 1; 43$YAML::Syck::ImplicitUnicode = 1;
33 44
34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
35 48
36our %COMMAND = (); 49our %COMMAND = ();
37our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
38 51
39our @EXTS = (); # list of extension package names 52our @EXTS = (); # list of extension package names
40our %EXTCMD = (); 53our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions 54our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps 55our %EXT_MAP = (); # pluggable maps
43 56
57our $RELOAD; # number of reloads so far
44our @EVENT; 58our @EVENT;
45our $LIBDIR = datadir . "/ext";
46 59
47our $TICK = MAX_TIME * 1e-6; 60our $CONFDIR = confdir;
61our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db";
71
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
48our $TICK_WATCHER; 73our $TICK_WATCHER;
49our $AIO_POLL_WATCHER; 74our $AIO_POLL_WATCHER;
50our $WRITE_RUNTIME_WATCHER; 75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
51our $NEXT_TICK; 76our $NEXT_TICK;
52our $NOW; 77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off
79
80our $BDB_POLL_WATCHER;
81our $DB_ENV;
53 82
54our %CFG; 83our %CFG;
55 84
56our $UPTIME; $UPTIME ||= time; 85our $UPTIME; $UPTIME ||= time;
57our $RUNTIME; 86our $RUNTIME;
58 87
59our %PLAYER; # all users 88our %PLAYER; # all users
60our %MAP; # all maps 89our %MAP; # all maps
61our $LINK_MAP; # the special {link} map, which is always available 90our $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 91
67# used to convert map paths into valid unix filenames by replacing / by ∕ 92# used to convert map paths into valid unix filenames by replacing / by ∕
68our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
69 94
95our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing
97our $tick_start; # for load detecting purposes
98
70binmode STDOUT; 99binmode STDOUT;
71binmode STDERR; 100binmode STDERR;
72 101
73# read virtual server time, if available 102# read virtual server time, if available
74unless ($RUNTIME || !-e cf::localdir . "/runtime") { 103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
75 open my $fh, "<", cf::localdir . "/runtime" 104 open my $fh, "<", "$LOCALDIR/runtime"
76 or die "unable to read runtime file: $!"; 105 or die "unable to read runtime file: $!";
77 $RUNTIME = <$fh> + 0.; 106 $RUNTIME = <$fh> + 0.;
78} 107}
79 108
80mkdir cf::localdir; 109mkdir $_
81mkdir cf::localdir . "/" . cf::playerdir; 110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
82mkdir cf::localdir . "/" . cf::tmpdir;
83mkdir cf::localdir . "/" . cf::uniquedir;
84mkdir $RANDOM_MAPS;
85 111
86our $EMERGENCY_POSITION; 112our $EMERGENCY_POSITION;
113
114sub cf::map::normalise;
87 115
88############################################################################# 116#############################################################################
89 117
90=head2 GLOBAL VARIABLES 118=head2 GLOBAL VARIABLES
91 119
… …
98=item $cf::RUNTIME 126=item $cf::RUNTIME
99 127
100The time this server has run, starts at 0 and is increased by $cf::TICK on 128The time this server has run, starts at 0 and is increased by $cf::TICK on
101every server tick. 129every server tick.
102 130
103=item $cf::LIBDIR 131=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
132$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
133$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
104 134
105The perl library directory, where extensions and cf-specific modules can 135Various directories - "/etc", read-only install directory, perl-library
106be found. It will be added to C<@INC> automatically. 136directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
137unique-items directory, player file directory, random maps directory and
138database environment.
107 139
108=item $cf::NOW 140=item $cf::NOW
109 141
110The time of the last (current) server tick. 142The time of the last (current) server tick.
111 143
112=item $cf::TICK 144=item $cf::TICK
113 145
114The interval between server ticks, in seconds. 146The interval between server ticks, in seconds.
147
148=item $cf::LOADAVG
149
150The current CPU load on the server (alpha-smoothed), as a value between 0
151(none) and 1 (overloaded), indicating how much time is spent on processing
152objects per tick. Healthy values are < 0.5.
153
154=item $cf::LOAD
155
156The raw value load value from the last tick.
115 157
116=item %cf::CFG 158=item %cf::CFG
117 159
118Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
119from wherever your confdir points to. 161from wherever your confdir points to.
120 162
121=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 163=item cf::wait_for_tick, cf::wait_for_tick_begin
122 164
123These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
124or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 166returns directly I<after> the tick processing (and consequently, can only wake one process
125processing has been done. Call C<< ->wait >> on them to maximise the 167per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
126window of cpu time available, or simply to synchronise to the server tick.
127 168
128=back 169=back
129 170
130=cut 171=cut
131 172
132BEGIN { 173BEGIN {
133 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
134 my $msg = join "", @_; 175 my $msg = join "", @_;
135 utf8::encode $msg;
136 176
137 $msg .= "\n" 177 $msg .= "\n"
138 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
139 179
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
140 LOG llevError, $msg; 183 LOG llevError, $msg;
141 }; 184 };
142} 185}
143 186
144@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
145@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
146@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
147@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
148@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
192@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
149@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 193@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
150 194
151# we bless all objects into (empty) derived classes to force a method lookup 195# we bless all objects into (empty) derived classes to force a method lookup
152# within the Safe compartment. 196# within the Safe compartment.
153for my $pkg (qw( 197for my $pkg (qw(
154 cf::global cf::attachable 198 cf::global cf::attachable
… …
162} 206}
163 207
164$Event::DIED = sub { 208$Event::DIED = sub {
165 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
166}; 210};
211
212#############################################################################
167 213
168=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
169 215
170=over 4 216=over 4
171 217
… …
190 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 236 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
191 $d 237 $d
192 } || "[unable to dump $_[0]: '$@']"; 238 } || "[unable to dump $_[0]: '$@']";
193} 239}
194 240
195use JSON::Syck (); # TODO# replace by JSON::PC once working 241use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
196 242
197=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
198 244
199Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
200 246
201=cut
202
203sub from_json($) {
204 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
205 JSON::Syck::Load $_[0]
206}
207
208=item $json = cf::to_json $ref 247=item $json = cf::to_json $ref
209 248
210Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
211
212=cut
213
214sub to_json($) {
215 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
216 JSON::Syck::Dump $_[0]
217}
218 250
219=item cf::lock_wait $string 251=item cf::lock_wait $string
220 252
221Wait until the given lock is available. See cf::lock_acquire. 253Wait until the given lock is available. See cf::lock_acquire.
222 254
… …
228returned. 260returned.
229 261
230Lock names should begin with a unique identifier (for example, cf::map::find 262Lock names should begin with a unique identifier (for example, cf::map::find
231uses map_find and cf::map::load uses map_load). 263uses map_find and cf::map::load uses map_load).
232 264
265=item $locked = cf::lock_active $string
266
267Return true if the lock is currently active, i.e. somebody has locked it.
268
233=cut 269=cut
234 270
235our %LOCK; 271our %LOCK;
236 272
237sub lock_wait($) { 273sub lock_wait($) {
… …
256 # wake up all waiters, to be on the safe side 292 # wake up all waiters, to be on the safe side
257 $_->ready for @{ delete $LOCK{$key} }; 293 $_->ready for @{ delete $LOCK{$key} };
258 } 294 }
259} 295}
260 296
297sub lock_active($) {
298 my ($key) = @_;
299
300 ! ! $LOCK{$key}
301}
302
261sub freeze_mainloop { 303sub freeze_mainloop {
262 return unless $TICK_WATCHER->is_active; 304 return unless $TICK_WATCHER->is_active;
263 305
264 my $guard = Coro::guard { 306 my $guard = Coro::guard {
265 $TICK_WATCHER->start; 307 $TICK_WATCHER->start;
266 $WRITE_RUNTIME_WATCHER->start;
267 }; 308 };
268 $WRITE_RUNTIME_WATCHER->stop;
269 $TICK_WATCHER->stop; 309 $TICK_WATCHER->stop;
270 $guard 310 $guard
271} 311}
272 312
273=item cf::async { BLOCK } 313=item cf::async { BLOCK }
… …
280 320
281BEGIN { *async = \&Coro::async_pool } 321BEGIN { *async = \&Coro::async_pool }
282 322
283=item cf::sync_job { BLOCK } 323=item cf::sync_job { BLOCK }
284 324
285The design of crossfire+ requires that the main coro ($Coro::main) is 325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
286always able to handle events or runnable, as crossfire+ is only partly 326is always able to handle events or runnable, as Crossfire TRT is only
287reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 327partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
328acceptable.
288 329
289If it must be done, put the blocking parts into C<sync_job>. This will run 330If it must be done, put the blocking parts into C<sync_job>. This will run
290the given BLOCK in another coroutine while waiting for the result. The 331the given BLOCK in another coroutine while waiting for the result. The
291server will be frozen during this time, so the block should either finish 332server will be frozen during this time, so the block should either finish
292fast or be very important. 333fast or be very important.
… …
295 336
296sub sync_job(&) { 337sub sync_job(&) {
297 my ($job) = @_; 338 my ($job) = @_;
298 339
299 if ($Coro::current == $Coro::main) { 340 if ($Coro::current == $Coro::main) {
341 my $time = Event::time;
342
300 # this is the main coro, too bad, we have to block 343 # this is the main coro, too bad, we have to block
301 # till the operation succeeds, freezing the server :/ 344 # till the operation succeeds, freezing the server :/
302 345
303 # TODO: use suspend/resume instead 346 # TODO: use suspend/resume instead
304 # (but this is cancel-safe) 347 # (but this is cancel-safe)
… …
315 358
316 while ($busy) { 359 while ($busy) {
317 Coro::cede or Event::one_event; 360 Coro::cede or Event::one_event;
318 } 361 }
319 362
363 $time = Event::time - $time;
364
365 LOG llevError | logBacktrace, Carp::longmess "long sync job"
366 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
367
368 $tick_start += $time; # do not account sync jobs to server load
369
320 wantarray ? @res : $res[0] 370 wantarray ? @res : $res[0]
321 } else { 371 } else {
322 # we are in another coroutine, how wonderful, everything just works 372 # we are in another coroutine, how wonderful, everything just works
323 373
324 $job->() 374 $job->()
… …
343 $EXT_CORO{$coro+0} = $coro; 393 $EXT_CORO{$coro+0} = $coro;
344 394
345 $coro 395 $coro
346} 396}
347 397
348sub write_runtime { 398=item fork_call { }, $args
349 my $runtime = cf::localdir . "/runtime";
350 399
351 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 400Executes the given code block with the given arguments in a seperate
352 or return; 401process, returning the results. Everything must be serialisable with
402Coro::Storable. May, of course, block. Note that the executed sub may
403never block itself or use any form of Event handling.
353 404
354 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 405=cut
355 (aio_write $fh, 0, (length $value), $value, 0) <= 0
356 and return;
357 406
358 aio_fsync $fh 407sub fork_call(&@) {
359 and return; 408 my ($cb, @args) = @_;
360 409
410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
414
415 if (my $pid = fork) {
361 close $fh 416 close $fh2;
362 or return;
363 417
364 aio_rename "$runtime~", $runtime 418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
365 and return; 419 $res = Coro::Storable::thaw $res;
366 420
421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
422
423 die $$res unless "ARRAY" eq ref $res;
424
425 return wantarray ? @$res : $res->[-1];
426 } else {
427 reset_signals;
428 local $SIG{__WARN__};
429 local $SIG{__DIE__};
430 eval {
431 close $fh1;
432
433 my @res = eval { $cb->(@args) };
434 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
435 };
436
437 warn $@ if $@;
438 _exit 0;
367 1 439 }
440}
441
442=item $value = cf::db_get $family => $key
443
444Returns a single value from the environment database.
445
446=item cf::db_put $family => $key => $value
447
448Stores the given C<$value> in the family. It can currently store binary
449data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450
451=cut
452
453our $DB;
454
455sub db_init {
456 unless ($DB) {
457 $DB = BDB::db_create $DB_ENV;
458
459 cf::sync_job {
460 eval {
461 $DB->set_flags (BDB::CHKSUM);
462
463 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465 cf::cleanup "db_open(db): $!" if $!;
466 };
467 cf::cleanup "db_open(db): $@" if $@;
468 };
469 }
470}
471
472sub db_get($$) {
473 my $key = "$_[0]/$_[1]";
474
475 cf::sync_job {
476 BDB::db_get $DB, undef, $key, my $data;
477
478 $! ? ()
479 : $data
480 }
481}
482
483sub db_put($$$) {
484 BDB::dbreq_pri 4;
485 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
486}
487
488=item cf::cache $id => [$paths...], $processversion => $process
489
490Generic caching function that returns the value of the resource $id,
491caching and regenerating as required.
492
493This function can block.
494
495=cut
496
497sub cache {
498 my ($id, $src, $processversion, $process) = @_;
499
500 my $meta =
501 join "\x00",
502 $processversion,
503 map {
504 aio_stat $_
505 and Carp::croak "$_: $!";
506
507 ($_, (stat _)[7,9])
508 } @$src;
509
510 my $dbmeta = db_get cache => "$id/meta";
511 if ($dbmeta ne $meta) {
512 # changed, we may need to process
513
514 my @data;
515 my $md5;
516
517 for (0 .. $#$src) {
518 0 <= aio_load $src->[$_], $data[$_]
519 or Carp::croak "$src->[$_]: $!";
520 }
521
522 # if processing is expensive, check
523 # checksum first
524 if (1) {
525 $md5 =
526 join "\x00",
527 $processversion,
528 map {
529 Coro::cede;
530 ($src->[$_], Digest::MD5::md5_hex $data[$_])
531 } 0.. $#$src;
532
533
534 my $dbmd5 = db_get cache => "$id/md5";
535 if ($dbmd5 eq $md5) {
536 db_put cache => "$id/meta", $meta;
537
538 return db_get cache => "$id/data";
539 }
540 }
541
542 my $t1 = Time::HiRes::time;
543 my $data = $process->(\@data);
544 my $t2 = Time::HiRes::time;
545
546 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
547
548 db_put cache => "$id/data", $data;
549 db_put cache => "$id/md5" , $md5;
550 db_put cache => "$id/meta", $meta;
551
552 return $data;
553 }
554
555 db_get cache => "$id/data"
556}
557
558=item cf::datalog type => key => value, ...
559
560Log a datalog packet of the given type with the given key-value pairs.
561
562=cut
563
564sub datalog($@) {
565 my ($type, %kv) = @_;
566 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
368} 567}
369 568
370=back 569=back
371 570
372=cut 571=cut
… …
379attach callbacks/event handlers (a collection of which is called an "attachment") 578attach callbacks/event handlers (a collection of which is called an "attachment")
380to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
381 580
382In the following description, CLASS can be any of C<global>, C<object> 581In the following description, CLASS can be any of C<global>, C<object>
383C<player>, C<client> or C<map> (i.e. the attachable objects in 582C<player>, C<client> or C<map> (i.e. the attachable objects in
384crossfire+). 583Crossfire TRT).
385 584
386=over 4 585=over 4
387 586
388=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
389 588
… …
552 $registry = $CB_TYPE[$object_type] ||= []; 751 $registry = $CB_TYPE[$object_type] ||= [];
553 752
554 } elsif ($type eq "subtype") { 753 } elsif ($type eq "subtype") {
555 defined $object_type or Carp::croak "subtype specified without type"; 754 defined $object_type or Carp::croak "subtype specified without type";
556 my $object_subtype = shift @arg; 755 my $object_subtype = shift @arg;
557 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 756 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
558 757
559 } elsif ($type eq "package") { 758 } elsif ($type eq "package") {
560 my $pkg = shift @arg; 759 my $pkg = shift @arg;
561 760
562 while (my ($name, $id) = each %cb_id) { 761 while (my ($name, $id) = each %cb_id) {
… …
591 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
592 } 791 }
593 792
594 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
595 } else { 794 } else {
596 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
597 } 796 }
598 797
599 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
600} 799}
601 800
… …
603 if (ref $_[0]) { 802 if (ref $_[0]) {
604 _object_attach @_; 803 _object_attach @_;
605 } else { 804 } else {
606 _attach shift->_attach_registry, @_; 805 _attach shift->_attach_registry, @_;
607 } 806 }
807 _recalc_want;
608}; 808};
609 809
610# all those should be optimised 810# all those should be optimised
611sub cf::attachable::detach { 811sub cf::attachable::detach {
612 my ($obj, $name) = @_; 812 my ($obj, $name) = @_;
… …
615 delete $obj->{_attachment}{$name}; 815 delete $obj->{_attachment}{$name};
616 reattach ($obj); 816 reattach ($obj);
617 } else { 817 } else {
618 Carp::croak "cannot, currently, detach class attachments"; 818 Carp::croak "cannot, currently, detach class attachments";
619 } 819 }
820 _recalc_want;
620}; 821};
621 822
622sub cf::attachable::attached { 823sub cf::attachable::attached {
623 my ($obj, $name) = @_; 824 my ($obj, $name) = @_;
624 825
… …
747 $filename, length $$rdata, scalar @$objs; 948 $filename, length $$rdata, scalar @$objs;
748 949
749 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 950 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
750 chmod SAVE_MODE, $fh; 951 chmod SAVE_MODE, $fh;
751 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 952 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
752 aio_fsync $fh; 953 aio_fsync $fh if $cf::USE_FSYNC;
753 close $fh; 954 close $fh;
754 955
755 if (@$objs) { 956 if (@$objs) {
756 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 957 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
757 chmod SAVE_MODE, $fh; 958 chmod SAVE_MODE, $fh;
758 my $data = Storable::nfreeze { version => 1, objs => $objs }; 959 my $data = Storable::nfreeze { version => 1, objs => $objs };
759 aio_write $fh, 0, (length $data), $data, 0; 960 aio_write $fh, 0, (length $data), $data, 0;
760 aio_fsync $fh; 961 aio_fsync $fh if $cf::USE_FSYNC;
761 close $fh; 962 close $fh;
762 aio_rename "$filename.pst~", "$filename.pst"; 963 aio_rename "$filename.pst~", "$filename.pst";
763 } 964 }
764 } else { 965 } else {
765 aio_unlink "$filename.pst"; 966 aio_unlink "$filename.pst";
… …
797 or return; 998 or return;
798 $av = eval { (Storable::thaw $av)->{objs} }; 999 $av = eval { (Storable::thaw $av)->{objs} };
799 } 1000 }
800 1001
801 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
802 $filename, length $data, scalar @{$av || []};#d# 1003 $filename, length $data, scalar @{$av || []};
803 return ($data, $av); 1004 return ($data, $av);
804} 1005}
1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
805 1012
806############################################################################# 1013#############################################################################
807# command handling &c 1014# command handling &c
808 1015
809=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
… …
822 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
823} 1030}
824 1031
825=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
826 1033
827Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
828 1035
829If the callback returns something, it is sent back as if reply was being 1036If the callback returns something, it is sent back as if reply was being
830called. 1037called.
831 1038
832=cut 1039=cut
… …
867 1074
868 cf::override; 1075 cf::override;
869 }, 1076 },
870); 1077);
871 1078
872sub load_extension {
873 my ($path) = @_;
874
875 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
876 my $base = $1;
877 my $pkg = $1;
878 $pkg =~ s/[^[:word:]]/_/g;
879 $pkg = "ext::$pkg";
880
881 warn "... loading '$path' into '$pkg'\n";
882
883 open my $fh, "<:utf8", $path
884 or die "$path: $!";
885
886 my $source =
887 "package $pkg; use strict; use utf8;\n"
888 . "#line 1 \"$path\"\n{\n"
889 . (do { local $/; <$fh> })
890 . "\n};\n1";
891
892 unless (eval $source) {
893 my $msg = $@ ? "$path: $@\n"
894 : "extension disabled.\n";
895 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
896 warn $@;
897 warn "mandatory extension failed to load, exiting.\n";
898 exit 1;
899 }
900 die $@;
901 }
902
903 push @EXTS, $pkg;
904}
905
906sub load_extensions { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
907 for my $ext (<$LIBDIR/*.ext>) { 1083 for my $path (<$LIBDIR/*.ext>) {
908 next unless -r $ext; 1084 next unless -r $path;
909 eval { 1085
910 load_extension $ext; 1086 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1087 my $base = $1;
1088 my $pkg = $1;
1089 $pkg =~ s/[^[:word:]]/_/g;
1090 $pkg = "ext::$pkg";
1091
1092 open my $fh, "<:utf8", $path
1093 or die "$path: $!";
1094
1095 my $source = do { local $/; <$fh> };
1096
1097 my %ext = (
1098 path => $path,
1099 base => $base,
1100 pkg => $pkg,
1101 );
1102
1103 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1104 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1105
1106 $ext{source} =
1107 "package $pkg; use strict; use utf8;\n"
1108 . "#line 1 \"$path\"\n{\n"
1109 . $source
1110 . "\n};\n1";
1111
1112 $todo{$base} = \%ext;
1113 }
1114
1115 my %done;
1116 while (%todo) {
1117 my $progress;
1118
1119 while (my ($k, $v) = each %todo) {
1120 for (split /,\s*/, $v->{meta}{depends}) {
1121 goto skip
1122 unless exists $done{$_};
1123 }
1124
1125 warn "... loading '$k' into '$v->{pkg}'\n";
1126
1127 unless (eval $v->{source}) {
1128 my $msg = $@ ? "$v->{path}: $@\n"
1129 : "$v->{base}: extension inactive.\n";
1130
1131 if (exists $v->{meta}{mandatory}) {
1132 warn $msg;
1133 warn "mandatory extension failed to load, exiting.\n";
1134 exit 1;
1135 }
1136
1137 warn $msg;
1138 }
1139
1140 $done{$k} = delete $todo{$k};
1141 push @EXTS, $v->{pkg};
1142 $progress = 1;
911 1 1143 }
912 } or warn "$ext not loaded: $@"; 1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
913 } 1149 };
914} 1150}
915 1151
916############################################################################# 1152#############################################################################
917 1153
1154=back
1155
918=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
919 1157
920Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
921 1159
922=cut 1160=cut
… …
934Returns the given player object, loading it if necessary (might block). 1172Returns the given player object, loading it if necessary (might block).
935 1173
936=cut 1174=cut
937 1175
938sub playerdir($) { 1176sub playerdir($) {
939 cf::localdir 1177 "$PLAYERDIR/"
940 . "/"
941 . cf::playerdir
942 . "/"
943 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1178 . (ref $_[0] ? $_[0]->ob->name : $_[0])
944} 1179}
945 1180
946sub path($) { 1181sub path($) {
947 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1182 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
948 1183
949 (playerdir $login) . "/$login.pl" 1184 (playerdir $login) . "/playerdata"
950} 1185}
951 1186
952sub find_active($) { 1187sub find_active($) {
953 $cf::PLAYER{$_[0]} 1188 $cf::PLAYER{$_[0]}
954 and $cf::PLAYER{$_[0]}->active 1189 and $cf::PLAYER{$_[0]}->active
… …
957 1192
958sub exists($) { 1193sub exists($) {
959 my ($login) = @_; 1194 my ($login) = @_;
960 1195
961 $cf::PLAYER{$login} 1196 $cf::PLAYER{$login}
962 or cf::sync_job { !aio_stat $login } 1197 or cf::sync_job { !aio_stat path $login }
963} 1198}
964 1199
965sub find($) { 1200sub find($) {
966 return $cf::PLAYER{$_[0]} || do { 1201 return $cf::PLAYER{$_[0]} || do {
967 my $login = $_[0]; 1202 my $login = $_[0];
968 1203
969 my $guard = cf::lock_acquire "user_find:$login"; 1204 my $guard = cf::lock_acquire "user_find:$login";
970 1205
971 $cf::PLAYER{$_[0]} || do { 1206 $cf::PLAYER{$_[0]} || do {
1207 # rename old playerfiles to new ones
1208 #TODO: remove when no longer required
1209 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1210 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1211 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1212 aio_unlink +(playerdir $login) . "/$login.pl";
1213
972 my $pl = load_pl path $login 1214 my $pl = load_pl path $login
973 or return; 1215 or return;
974 $cf::PLAYER{$login} = $pl 1216 $cf::PLAYER{$login} = $pl
975 } 1217 }
976 } 1218 }
… …
1013 1255
1014=cut 1256=cut
1015 1257
1016sub quit_character { 1258sub quit_character {
1017 my ($pl) = @_; 1259 my ($pl) = @_;
1260
1261 my $name = $pl->ob->name;
1018 1262
1019 $pl->{deny_save} = 1; 1263 $pl->{deny_save} = 1;
1020 $pl->password ("*"); # this should lock out the player until we nuked the dir 1264 $pl->password ("*"); # this should lock out the player until we nuked the dir
1021 1265
1022 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1266 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1027 my $path = playerdir $pl; 1271 my $path = playerdir $pl;
1028 my $temp = "$path~$cf::RUNTIME~deleting~"; 1272 my $temp = "$path~$cf::RUNTIME~deleting~";
1029 aio_rename $path, $temp; 1273 aio_rename $path, $temp;
1030 delete $cf::PLAYER{$pl->ob->name}; 1274 delete $cf::PLAYER{$pl->ob->name};
1031 $pl->destroy; 1275 $pl->destroy;
1276
1277 my $prefix = qr<^~\Q$name\E/>;
1278
1279 # nuke player maps
1280 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1281
1032 IO::AIO::aio_rmtree $temp; 1282 IO::AIO::aio_rmtree $temp;
1283}
1284
1285=item $pl->kick
1286
1287Kicks a player out of the game. This destroys the connection.
1288
1289=cut
1290
1291sub kick {
1292 my ($pl, $kicker) = @_;
1293
1294 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1295 $pl->killer ("kicked");
1296 $pl->ns->destroy;
1033} 1297}
1034 1298
1035=item cf::player::list_logins 1299=item cf::player::list_logins
1036 1300
1037Returns am arrayref of all valid playernames in the system, can take a 1301Returns am arrayref of all valid playernames in the system, can take a
1038while and may block, so not sync_job-capable, ever. 1302while and may block, so not sync_job-capable, ever.
1039 1303
1040=cut 1304=cut
1041 1305
1042sub list_logins { 1306sub list_logins {
1043 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1307 my $dirs = aio_readdir $PLAYERDIR
1044 or return []; 1308 or return [];
1045 1309
1046 my @logins; 1310 my @logins;
1047 1311
1048 for my $login (@$dirs) { 1312 for my $login (@$dirs) {
… …
1065=cut 1329=cut
1066 1330
1067sub maps($) { 1331sub maps($) {
1068 my ($pl) = @_; 1332 my ($pl) = @_;
1069 1333
1334 $pl = ref $pl ? $pl->ob->name : $pl;
1335
1070 my $files = aio_readdir playerdir $pl 1336 my $files = aio_readdir playerdir $pl
1071 or return; 1337 or return;
1072 1338
1073 my @paths; 1339 my @paths;
1074 1340
1075 for (@$files) { 1341 for (@$files) {
1076 utf8::decode $_; 1342 utf8::decode $_;
1077 next if /\.(?:pl|pst)$/; 1343 next if /\.(?:pl|pst)$/;
1078 next unless /^$PATH_SEP/o; 1344 next unless /^$PATH_SEP/o;
1079 1345
1080 s/\.map$//; 1346 push @paths, cf::map::normalise "~$pl/$_";
1081 push @paths, "~" . $pl->ob->name . "/" . $_;
1082 } 1347 }
1083 1348
1084 \@paths 1349 \@paths
1085} 1350}
1086 1351
1087=item $player->ext_reply ($msgid, $msgtype, %msg) 1352=item $player->ext_reply ($msgid, %msg)
1088 1353
1089Sends an ext reply to the player. 1354Sends an ext reply to the player.
1090 1355
1091=cut 1356=cut
1092 1357
1093sub ext_reply($$$%) { 1358sub ext_reply($$%) {
1094 my ($self, $id, %msg) = @_; 1359 my ($self, $id, %msg) = @_;
1095 1360
1096 $msg{msgid} = $id; 1361 $msg{msgid} = $id;
1097 1362
1098 $self->send ("ext " . cf::to_json \%msg); 1363 $self->send ("ext " . cf::to_json \%msg);
1099} 1364}
1100 1365
1101package cf; 1366=item $player->ext_event ($type, %msg)
1367
1368Sends an ext event to the client.
1369
1370=cut
1371
1372sub ext_event($$%) {
1373 my ($self, $type, %msg) = @_;
1374
1375 $self->ns->ext_event ($type, %msg);
1376}
1377
1378=head3 cf::region
1379
1380=over 4
1381
1382=cut
1383
1384package cf::region;
1385
1386=item cf::region::find_by_path $path
1387
1388Tries to decuce the likely region for a map knowing only its path.
1389
1390=cut
1391
1392sub find_by_path($) {
1393 my ($path) = @_;
1394
1395 my ($match, $specificity);
1396
1397 for my $region (list) {
1398 if ($region->match && $path =~ $region->match) {
1399 ($match, $specificity) = ($region, $region->specificity)
1400 if $region->specificity > $specificity;
1401 }
1402 }
1403
1404 $match
1405}
1102 1406
1103=back 1407=back
1104
1105 1408
1106=head3 cf::map 1409=head3 cf::map
1107 1410
1108=over 4 1411=over 4
1109 1412
… …
1121our $MAX_RESET = 3600; 1424our $MAX_RESET = 3600;
1122our $DEFAULT_RESET = 3000; 1425our $DEFAULT_RESET = 3000;
1123 1426
1124sub generate_random_map { 1427sub generate_random_map {
1125 my ($self, $rmp) = @_; 1428 my ($self, $rmp) = @_;
1126
1127 # mit "rum" bekleckern, nicht 1429 # mit "rum" bekleckern, nicht
1128 $self->_create_random_map ( 1430 $self->_create_random_map (
1129 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1431 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1130 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1432 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1131 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1433 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1138 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1440 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1139 (cf::region::find $rmp->{region}), $rmp->{custom} 1441 (cf::region::find $rmp->{region}), $rmp->{custom}
1140 ) 1442 )
1141} 1443}
1142 1444
1445=item cf::map->register ($regex, $prio)
1446
1447Register a handler for the map path matching the given regex at the
1448givne priority (higher is better, built-in handlers have priority 0, the
1449default).
1450
1451=cut
1452
1143sub register { 1453sub register {
1144 my (undef, $regex) = @_; 1454 my (undef, $regex, $prio) = @_;
1145 my $pkg = caller; 1455 my $pkg = caller;
1146 1456
1147 no strict; 1457 no strict;
1148 push @{"$pkg\::ISA"}, __PACKAGE__; 1458 push @{"$pkg\::ISA"}, __PACKAGE__;
1149 1459
1150 $EXT_MAP{$pkg} = qr<$regex>; 1460 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1151} 1461}
1152 1462
1153# also paths starting with '/' 1463# also paths starting with '/'
1154$EXT_MAP{"cf::map"} = qr{^(?=/)}; 1464$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1155 1465
1156sub thawer_merge { 1466sub thawer_merge {
1157 my ($self, $merge) = @_; 1467 my ($self, $merge) = @_;
1158 1468
1159 # we have to keep some variables in memory intact 1469 # we have to keep some variables in memory intact
1160 local $self->{path}; 1470 local $self->{path};
1161 local $self->{load_path}; 1471 local $self->{load_path};
1162 local $self->{deny_save};
1163 local $self->{deny_reset};
1164 1472
1165 $self->SUPER::thawer_merge ($merge); 1473 $self->SUPER::thawer_merge ($merge);
1166} 1474}
1167 1475
1168sub normalise { 1476sub normalise {
1169 my ($path, $base) = @_; 1477 my ($path, $base) = @_;
1478
1479 $path = "$path"; # make sure its a string
1480
1481 $path =~ s/\.map$//;
1170 1482
1171 # map plan: 1483 # map plan:
1172 # 1484 #
1173 # /! non-realised random map exit (special hack!) 1485 # /! non-realised random map exit (special hack!)
1174 # {... are special paths that are not being touched 1486 # {... are special paths that are not being touched
… …
1202 1514
1203 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object 1515 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1204 1516
1205 $path = normalise $path, $base; 1517 $path = normalise $path, $base;
1206 1518
1207 for my $pkg (keys %EXT_MAP) { 1519 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1208 if ($path =~ $EXT_MAP{$pkg}) { 1520 if ($path =~ $EXT_MAP{$pkg}[1]) {
1209 my $self = bless cf::map::new, $pkg; 1521 my $self = bless cf::map::new, $pkg;
1210 $self->{path} = $path; $self->path ($path); 1522 $self->{path} = $path; $self->path ($path);
1211 $self->init; # pass $1 etc. 1523 $self->init; # pass $1 etc.
1212 return $self; 1524 return $self;
1213 } 1525 }
1214 } 1526 }
1215 1527
1216 Carp::carp "unable to resolve path '$path'."; 1528 Carp::carp "unable to resolve path '$path' (base '$base').";
1217 () 1529 ()
1218} 1530}
1219 1531
1220sub init { 1532sub init {
1221 my ($self) = @_; 1533 my ($self) = @_;
… …
1236 1548
1237# the original (read-only) location 1549# the original (read-only) location
1238sub load_path { 1550sub load_path {
1239 my ($self) = @_; 1551 my ($self) = @_;
1240 1552
1241 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1553 "$MAPDIR/$self->{path}.map"
1242} 1554}
1243 1555
1244# the temporary/swap location 1556# the temporary/swap location
1245sub save_path { 1557sub save_path {
1246 my ($self) = @_; 1558 my ($self) = @_;
1247 1559
1248 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1560 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1249 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path 1561 "$TMPDIR/$path.map"
1250} 1562}
1251 1563
1252# the unique path, undef == no special unique path 1564# the unique path, undef == no special unique path
1253sub uniq_path { 1565sub uniq_path {
1254 my ($self) = @_; 1566 my ($self) = @_;
1255 1567
1256 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1568 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1257 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1569 "$UNIQUEDIR/$path"
1258} 1570}
1259 1571
1260# and all this just because we cannot iterate over 1572# and all this just because we cannot iterate over
1261# all maps in C++... 1573# all maps in C++...
1262sub change_all_map_light { 1574sub change_all_map_light {
… …
1264 1576
1265 $_->change_map_light ($change) 1577 $_->change_map_light ($change)
1266 for grep $_->outdoor, values %cf::MAP; 1578 for grep $_->outdoor, values %cf::MAP;
1267} 1579}
1268 1580
1581sub decay_objects {
1582 my ($self) = @_;
1583
1584 return if $self->{deny_reset};
1585
1586 $self->do_decay_objects;
1587}
1588
1269sub unlink_save { 1589sub unlink_save {
1270 my ($self) = @_; 1590 my ($self) = @_;
1271 1591
1272 utf8::encode (my $save = $self->save_path); 1592 utf8::encode (my $save = $self->save_path);
1273 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1593 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1276 1596
1277sub load_header_from($) { 1597sub load_header_from($) {
1278 my ($self, $path) = @_; 1598 my ($self, $path) = @_;
1279 1599
1280 utf8::encode $path; 1600 utf8::encode $path;
1281 aio_open $path, O_RDONLY, 0 1601 #aio_open $path, O_RDONLY, 0
1282 or return; 1602 # or return;
1283 1603
1284 $self->_load_header ($path) 1604 $self->_load_header ($path)
1285 or return; 1605 or return;
1286 1606
1287 $self->{load_path} = $path; 1607 $self->{load_path} = $path;
1288 1608
1289 1 1609 1
1290} 1610}
1291 1611
1292sub load_orig { 1612sub load_header_orig {
1293 my ($self) = @_; 1613 my ($self) = @_;
1294 1614
1295 $self->load_header_from ($self->load_path) 1615 $self->load_header_from ($self->load_path)
1296} 1616}
1297 1617
1298sub load_temp { 1618sub load_header_temp {
1299 my ($self) = @_; 1619 my ($self) = @_;
1300 1620
1301 $self->load_header_from ($self->save_path) 1621 $self->load_header_from ($self->save_path)
1622}
1623
1624sub prepare_temp {
1625 my ($self) = @_;
1626
1627 $self->last_access ((delete $self->{last_access})
1628 || $cf::RUNTIME); #d#
1629 # safety
1630 $self->{instantiate_time} = $cf::RUNTIME
1631 if $self->{instantiate_time} > $cf::RUNTIME;
1632}
1633
1634sub prepare_orig {
1635 my ($self) = @_;
1636
1637 $self->{load_original} = 1;
1638 $self->{instantiate_time} = $cf::RUNTIME;
1639 $self->last_access ($cf::RUNTIME);
1640 $self->instantiate;
1302} 1641}
1303 1642
1304sub load_header { 1643sub load_header {
1305 my ($self) = @_; 1644 my ($self) = @_;
1306 1645
1307 if ($self->load_temp) { 1646 if ($self->load_header_temp) {
1308 $self->last_access ((delete $self->{last_access}) 1647 $self->prepare_temp;
1309 || $cf::RUNTIME); #d#
1310 # safety
1311 $self->{instantiate_time} = $cf::RUNTIME
1312 if $self->{instantiate_time} > $cf::RUNTIME;
1313 } else { 1648 } else {
1314 $self->load_orig 1649 $self->load_header_orig
1315 or return; 1650 or return;
1316 1651 $self->prepare_orig;
1317 $self->{load_original} = 1;
1318 $self->{instantiate_time} = $cf::RUNTIME;
1319 $self->last_access ($cf::RUNTIME);
1320 $self->instantiate;
1321 } 1652 }
1653
1654 $self->{deny_reset} = 1
1655 if $self->no_reset;
1656
1657 $self->default_region (cf::region::find_by_path $self->{path})
1658 unless $self->default_region;
1322 1659
1323 1 1660 1
1324} 1661}
1325 1662
1326sub find; 1663sub find;
… …
1339 $map->{last_save} = $cf::RUNTIME; 1676 $map->{last_save} = $cf::RUNTIME;
1340 1677
1341 $map->load_header 1678 $map->load_header
1342 or return; 1679 or return;
1343 1680
1344 if ($map->should_reset) { 1681 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1682 # doing this can freeze the server in a sync job, obviously
1345 $cf::WAIT_FOR_TICK->wait; 1683 #$cf::WAIT_FOR_TICK->wait;
1346 $map->reset; 1684 $map->reset;
1347 undef $guard; 1685 undef $guard;
1348 $map = find $path 1686 return find $path;
1349 or return;
1350 } 1687 }
1351 1688
1352 $cf::MAP{$path} = $map 1689 $cf::MAP{$path} = $map
1353 } 1690 }
1354} 1691}
1692
1693sub pre_load { }
1694sub post_load { }
1355 1695
1356sub load { 1696sub load {
1357 my ($self) = @_; 1697 my ($self) = @_;
1358 1698
1699 local $self->{deny_reset} = 1; # loading can take a long time
1700
1359 my $path = $self->{path}; 1701 my $path = $self->{path};
1702
1703 {
1360 my $guard = cf::lock_acquire "map_load:$path"; 1704 my $guard = cf::lock_acquire "map_load:$path";
1361 1705
1362 return if $self->in_memory != cf::MAP_SWAPPED; 1706 return if $self->in_memory != cf::MAP_SWAPPED;
1363 1707
1364 $self->in_memory (cf::MAP_LOADING); 1708 $self->in_memory (cf::MAP_LOADING);
1365 1709
1366 $self->alloc; 1710 $self->alloc;
1367 $self->_load_objects ($self->{load_path}, 1)
1368 or return;
1369 1711
1370 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1712 $self->pre_load;
1371 if delete $self->{load_original};
1372
1373 if (my $uniq = $self->uniq_path) {
1374 utf8::encode $uniq;
1375 if (aio_open $uniq, O_RDONLY, 0) {
1376 $self->clear_unique_items;
1377 $self->_load_objects ($uniq, 0);
1378 }
1379 }
1380
1381 Coro::cede;
1382
1383 # now do the right thing for maps
1384 $self->link_multipart_objects;
1385
1386 unless ($self->{deny_activate}) {
1387 $self->decay_objects;
1388 $self->fix_auto_apply;
1389 $self->update_buttons;
1390 Coro::cede; 1713 Coro::cede;
1391 $self->set_darkness_map; 1714
1715 $self->_load_objects ($self->{load_path}, 1)
1716 or return;
1717
1718 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1719 if delete $self->{load_original};
1720
1721 if (my $uniq = $self->uniq_path) {
1722 utf8::encode $uniq;
1723 if (aio_open $uniq, O_RDONLY, 0) {
1724 $self->clear_unique_items;
1725 $self->_load_objects ($uniq, 0);
1726 }
1727 }
1728
1729 Coro::cede;
1730 # now do the right thing for maps
1731 $self->link_multipart_objects;
1392 $self->difficulty ($self->estimate_difficulty) 1732 $self->difficulty ($self->estimate_difficulty)
1393 unless $self->difficulty; 1733 unless $self->difficulty;
1394 Coro::cede; 1734 Coro::cede;
1735
1736 unless ($self->{deny_activate}) {
1737 $self->decay_objects;
1738 $self->fix_auto_apply;
1739 $self->update_buttons;
1740 Coro::cede;
1741 $self->set_darkness_map;
1742 Coro::cede;
1395 $self->activate; 1743 $self->activate;
1396 } 1744 }
1397 1745
1398 $self->in_memory (cf::MAP_IN_MEMORY); 1746 $self->in_memory (cf::MAP_IN_MEMORY);
1747 }
1748
1749 $self->post_load;
1399} 1750}
1400 1751
1401sub customise_for { 1752sub customise_for {
1402 my ($self, $ob) = @_; 1753 my ($self, $ob) = @_;
1403 1754
1404 return find "~" . $ob->name . "/" . $self->{path} 1755 return find "~" . $ob->name . "/" . $self->{path}
1405 if $self->per_player; 1756 if $self->per_player;
1757
1758# return find "?party/" . $ob->name . "/" . $self->{path}
1759# if $self->per_party;
1406 1760
1407 $self 1761 $self
1408} 1762}
1409 1763
1410# find and load all maps in the 3x3 area around a map 1764# find and load all maps in the 3x3 area around a map
… …
1442 1796
1443 cf::sync_job { $map->load }; 1797 cf::sync_job { $map->load };
1444} 1798}
1445 1799
1446our %MAP_PREFETCH; 1800our %MAP_PREFETCH;
1447our $MAP_PREFETCHER = Coro::async { 1801our $MAP_PREFETCHER = undef;
1448 while () {
1449 for my $path (keys %MAP_PREFETCH) {
1450 my $map = find $path
1451 or next;
1452 $map->load;
1453
1454 delete $MAP_PREFETCH{$path};
1455 }
1456 Coro::schedule;
1457 }
1458};
1459 1802
1460sub find_async { 1803sub find_async {
1461 my ($path, $origin) = @_; 1804 my ($path, $origin) = @_;
1462 1805
1463 $path = normalise $path, $origin && $origin->{path}; 1806 $path = normalise $path, $origin && $origin->{path};
1464 1807
1465 if (my $map = $cf::MAP{$path}) { 1808 if (my $map = $cf::MAP{$path}) {
1466 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1809 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1467 } 1810 }
1468 1811
1469 $MAP_PREFETCH{$path} = 0; 1812 undef $MAP_PREFETCH{$path};
1813 $MAP_PREFETCHER ||= cf::async {
1814 while (%MAP_PREFETCH) {
1815 for my $path (keys %MAP_PREFETCH) {
1816 my $map = find $path
1817 or next;
1818 $map->load;
1819
1820 delete $MAP_PREFETCH{$path};
1821 }
1822 }
1823 undef $MAP_PREFETCHER;
1824 };
1470 $MAP_PREFETCHER->ready; 1825 $MAP_PREFETCHER->prio (6);
1471 1826
1472 () 1827 ()
1473} 1828}
1474 1829
1475sub save { 1830sub save {
… …
1520 1875
1521sub reset_at { 1876sub reset_at {
1522 my ($self) = @_; 1877 my ($self) = @_;
1523 1878
1524 # TODO: safety, remove and allow resettable per-player maps 1879 # TODO: safety, remove and allow resettable per-player maps
1525 return 1e99 if $self->isa ("ext::map_per_player");#d#
1526 return 1e99 if $self->{deny_reset}; 1880 return 1e99 if $self->{deny_reset};
1527 1881
1528 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1882 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1529 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1883 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1530 1884
… …
1541 my ($self) = @_; 1895 my ($self) = @_;
1542 1896
1543 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1897 my $lock = cf::lock_acquire "map_data:$self->{path}";
1544 1898
1545 return if $self->players; 1899 return if $self->players;
1546 return if $self->isa ("ext::map_per_player");#d#
1547 1900
1548 warn "resetting map ", $self->path;#d# 1901 warn "resetting map ", $self->path;
1902
1903 $self->in_memory (cf::MAP_SWAPPED);
1904
1905 # need to save uniques path
1906 unless ($self->{deny_save}) {
1907 my $uniq = $self->uniq_path; utf8::encode $uniq;
1908
1909 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1910 if $uniq;
1911 }
1549 1912
1550 delete $cf::MAP{$self->path}; 1913 delete $cf::MAP{$self->path};
1551 1914
1552 $self->in_memory (cf::MAP_SWAPPED);
1553 $self->clear; 1915 $self->clear;
1554 1916
1555 $_->clear_links_to ($self) for values %cf::MAP; 1917 $_->clear_links_to ($self) for values %cf::MAP;
1556 1918
1557 $self->unlink_save; 1919 $self->unlink_save;
… …
1576 $cf::MAP{$self->path} = $self; 1938 $cf::MAP{$self->path} = $self;
1577 1939
1578 $self->reset; # polite request, might not happen 1940 $self->reset; # polite request, might not happen
1579} 1941}
1580 1942
1943=item $maps = cf::map::tmp_maps
1944
1945Returns an arrayref with all map paths of currently instantiated and saved
1946maps. May block.
1947
1948=cut
1949
1950sub tmp_maps() {
1951 [
1952 map {
1953 utf8::decode $_;
1954 /\.map$/
1955 ? normalise $_
1956 : ()
1957 } @{ aio_readdir $TMPDIR or [] }
1958 ]
1959}
1960
1961=item $maps = cf::map::random_maps
1962
1963Returns an arrayref with all map paths of currently instantiated and saved
1964random maps. May block.
1965
1966=cut
1967
1968sub random_maps() {
1969 [
1970 map {
1971 utf8::decode $_;
1972 /\.map$/
1973 ? normalise "?random/$_"
1974 : ()
1975 } @{ aio_readdir $RANDOMDIR or [] }
1976 ]
1977}
1978
1581=item cf::map::unique_maps 1979=item cf::map::unique_maps
1582 1980
1583Returns an arrayref of paths of all shared maps that have 1981Returns an arrayref of paths of all shared maps that have
1584instantiated unique items. May block. 1982instantiated unique items. May block.
1585 1983
1586=cut 1984=cut
1587 1985
1588sub unique_maps() { 1986sub unique_maps() {
1589 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 1987 [
1590 or return; 1988 map {
1591
1592 my @paths;
1593
1594 for (@$files) {
1595 utf8::decode $_; 1989 utf8::decode $_;
1596 next if /\.pst$/;
1597 next unless /^$PATH_SEP/o;
1598
1599 s/\.map$//; 1990 /\.map$/
1600 push @paths, $_; 1991 ? normalise $_
1992 : ()
1993 } @{ aio_readdir $UNIQUEDIR or [] }
1601 } 1994 ]
1602
1603 \@paths
1604} 1995}
1605 1996
1606package cf; 1997package cf;
1607 1998
1608=back 1999=back
… …
1699=cut 2090=cut
1700 2091
1701sub link_map { 2092sub link_map {
1702 unless ($LINK_MAP) { 2093 unless ($LINK_MAP) {
1703 $LINK_MAP = cf::map::find "{link}" 2094 $LINK_MAP = cf::map::find "{link}"
1704 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 2095 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1705 $LINK_MAP->load; 2096 $LINK_MAP->load;
1706 } 2097 }
1707 2098
1708 $LINK_MAP 2099 $LINK_MAP
1709} 2100}
… …
1714 $self->deactivate_recursive; 2105 $self->deactivate_recursive;
1715 2106
1716 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2107 return if UNIVERSAL::isa $self->map, "ext::map_link";
1717 2108
1718 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2109 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1719 if $self->map; 2110 if $self->map && $self->map->{path} ne "{link}";
1720 2111
1721 $self->enter_map ($LINK_MAP || link_map, 20, 20); 2112 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1722} 2113}
1723 2114
1724sub cf::object::player::leave_link { 2115sub cf::object::player::leave_link {
1725 my ($self, $map, $x, $y) = @_; 2116 my ($self, $map, $x, $y) = @_;
2117
2118 return unless $self->contr->active;
1726 2119
1727 my $link_pos = delete $self->{_link_pos}; 2120 my $link_pos = delete $self->{_link_pos};
1728 2121
1729 unless ($map) { 2122 unless ($map) {
1730 # restore original map position 2123 # restore original map position
… …
1748 $map->load; 2141 $map->load;
1749 $map->load_diag; 2142 $map->load_diag;
1750 2143
1751 return unless $self->contr->active; 2144 return unless $self->contr->active;
1752 $self->activate_recursive; 2145 $self->activate_recursive;
2146
2147 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1753 $self->enter_map ($map, $x, $y); 2148 $self->enter_map ($map, $x, $y);
1754} 2149}
1755 2150
1756cf::player->attach (
1757 on_logout => sub {
1758 my ($pl) = @_;
1759
1760 # abort map switching before logout
1761 if ($pl->ob->{_link_pos}) {
1762 cf::sync_job {
1763 $pl->ob->leave_link
1764 };
1765 }
1766 },
1767 on_login => sub {
1768 my ($pl) = @_;
1769
1770 # try to abort aborted map switching on player login :)
1771 # should happen only on crashes
1772 if ($pl->ob->{_link_pos}) {
1773 $pl->ob->enter_link;
1774 (async {
1775 # we need this sleep as the login has a concurrent enter_exit running
1776 # and this sleep increases chances of the player not ending up in scorn
1777 $pl->ob->reply (undef,
1778 "There was an internal problem at your last logout, "
1779 . "the server will try to bring you to your intended destination in a second.",
1780 cf::NDI_RED);
1781 Coro::Timer::sleep 1;
1782 $pl->ob->leave_link;
1783 })->prio (2);
1784 }
1785 },
1786);
1787
1788=item $player_object->goto ($path, $x, $y) 2151=item $player_object->goto ($path, $x, $y[, $check->($map)])
1789 2152
2153Moves the player to the given map-path and coordinates by first freezing
2154her, loading and preparing them map, calling the provided $check callback
2155that has to return the map if sucecssful, and then unfreezes the player on
2156the new (success) or old (failed) map position.
2157
1790=cut 2158=cut
2159
2160our $GOTOGEN;
1791 2161
1792sub cf::object::player::goto { 2162sub cf::object::player::goto {
1793 my ($self, $path, $x, $y) = @_; 2163 my ($self, $path, $x, $y, $check) = @_;
2164
2165 # do generation counting so two concurrent goto's will be executed in-order
2166 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1794 2167
1795 $self->enter_link; 2168 $self->enter_link;
1796 2169
1797 (async { 2170 (async {
2171 my $map = eval {
1798 my $map = cf::map::find $path; 2172 my $map = cf::map::find $path;
2173
2174 if ($map) {
1799 $map = $map->customise_for ($self) if $map; 2175 $map = $map->customise_for ($self);
1800 2176 $map = $check->($map) if $check && $map;
1801# warn "entering ", $map->path, " at ($x, $y)\n" 2177 } else {
1802# if $map;
1803
1804 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2178 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2179 }
1805 2180
2181 $map
2182 };
2183
2184 if ($@) {
2185 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2186 LOG llevError | logBacktrace, Carp::longmess $@;
2187 }
2188
2189 if ($gen == $self->{_goto_generation}) {
2190 delete $self->{_goto_generation};
1806 $self->leave_link ($map, $x, $y); 2191 $self->leave_link ($map, $x, $y);
2192 }
1807 })->prio (1); 2193 })->prio (1);
1808} 2194}
1809 2195
1810=item $player_object->enter_exit ($exit_object) 2196=item $player_object->enter_exit ($exit_object)
1811 2197
… …
1813 2199
1814sub parse_random_map_params { 2200sub parse_random_map_params {
1815 my ($spec) = @_; 2201 my ($spec) = @_;
1816 2202
1817 my $rmp = { # defaults 2203 my $rmp = { # defaults
1818 xsize => 10, 2204 xsize => (cf::rndm 15, 40),
1819 ysize => 10, 2205 ysize => (cf::rndm 15, 40),
2206 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2207 #layout => string,
1820 }; 2208 };
1821 2209
1822 for (split /\n/, $spec) { 2210 for (split /\n/, $spec) {
1823 my ($k, $v) = split /\s+/, $_, 2; 2211 my ($k, $v) = split /\s+/, $_, 2;
1824 2212
… …
1828 $rmp 2216 $rmp
1829} 2217}
1830 2218
1831sub prepare_random_map { 2219sub prepare_random_map {
1832 my ($exit) = @_; 2220 my ($exit) = @_;
2221
2222 my $guard = cf::lock_acquire "exit_prepare:$exit";
1833 2223
1834 # all this does is basically replace the /! path by 2224 # all this does is basically replace the /! path by
1835 # a new random map path (?random/...) with a seed 2225 # a new random map path (?random/...) with a seed
1836 # that depends on the exit object 2226 # that depends on the exit object
1837 2227
1838 my $rmp = parse_random_map_params $exit->msg; 2228 my $rmp = parse_random_map_params $exit->msg;
1839 2229
1840 if ($exit->map) { 2230 if ($exit->map) {
1841 $rmp->{region} = $exit->map->region_name; 2231 $rmp->{region} = $exit->region->name;
1842 $rmp->{origin_map} = $exit->map->path; 2232 $rmp->{origin_map} = $exit->map->path;
1843 $rmp->{origin_x} = $exit->x; 2233 $rmp->{origin_x} = $exit->x;
1844 $rmp->{origin_y} = $exit->y; 2234 $rmp->{origin_y} = $exit->y;
1845 } 2235 }
1846 2236
1847 $rmp->{random_seed} ||= $exit->random_seed; 2237 $rmp->{random_seed} ||= $exit->random_seed;
1848 2238
1849 my $data = cf::to_json $rmp; 2239 my $data = cf::to_json $rmp;
1850 my $md5 = Digest::MD5::md5_hex $data; 2240 my $md5 = Digest::MD5::md5_hex $data;
2241 my $meta = "$RANDOMDIR/$md5.meta";
1851 2242
1852 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2243 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1853 aio_write $fh, 0, (length $data), $data, 0; 2244 aio_write $fh, 0, (length $data), $data, 0;
2245 undef $fh;
2246 aio_rename "$meta~", $meta;
1854 2247
1855 $exit->slaying ("?random/$md5"); 2248 $exit->slaying ("?random/$md5");
1856 $exit->msg (undef); 2249 $exit->msg (undef);
1857 } 2250 }
1858} 2251}
1859 2252
1860sub cf::object::player::enter_exit { 2253sub cf::object::player::enter_exit {
1861 my ($self, $exit) = @_; 2254 my ($self, $exit) = @_;
1862 2255
1863 return unless $self->type == cf::PLAYER; 2256 return unless $self->type == cf::PLAYER;
2257
2258 if ($exit->slaying eq "/!") {
2259 #TODO: this should de-fi-ni-te-ly not be a sync-job
2260 # the problem is that $exit might not survive long enough
2261 # so it needs to be done right now, right here
2262 cf::sync_job { prepare_random_map $exit };
2263 }
2264
2265 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2266 my $hp = $exit->stats->hp;
2267 my $sp = $exit->stats->sp;
1864 2268
1865 $self->enter_link; 2269 $self->enter_link;
1866 2270
1867 (async { 2271 (async {
1868 $self->deactivate_recursive; # just to be sure 2272 $self->deactivate_recursive; # just to be sure
1869 unless (eval { 2273 unless (eval {
1870 prepare_random_map $exit 2274 $self->goto ($slaying, $hp, $sp);
1871 if $exit->slaying eq "/!";
1872
1873 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1874 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1875 2275
1876 1; 2276 1;
1877 }) { 2277 }) {
1878 $self->message ("Something went wrong deep within the crossfire server. " 2278 $self->message ("Something went wrong deep within the crossfire server. "
1879 . "I'll try to bring you back to the map you were before. " 2279 . "I'll try to bring you back to the map you were before. "
1880 . "Please report this to the dungeon master!", 2280 . "Please report this to the dungeon master!",
1881 cf::NDI_UNIQUE | cf::NDI_RED); 2281 cf::NDI_UNIQUE | cf::NDI_RED);
1882 2282
1883 warn "ERROR in enter_exit: $@"; 2283 warn "ERROR in enter_exit: $@";
1884 $self->leave_link; 2284 $self->leave_link;
1885 } 2285 }
1886 })->prio (1); 2286 })->prio (1);
… …
1899 2299
1900sub cf::client::send_drawinfo { 2300sub cf::client::send_drawinfo {
1901 my ($self, $text, $flags) = @_; 2301 my ($self, $text, $flags) = @_;
1902 2302
1903 utf8::encode $text; 2303 utf8::encode $text;
1904 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2304 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1905} 2305}
1906 2306
2307=item $client->ext_event ($type, %msg)
2308
2309Sends an exti event to the client.
2310
2311=cut
2312
2313sub cf::client::ext_event($$%) {
2314 my ($self, $type, %msg) = @_;
2315
2316 $msg{msgtype} = "event_$type";
2317 $self->send_packet ("ext " . cf::to_json \%msg);
2318}
1907 2319
1908=item $success = $client->query ($flags, "text", \&cb) 2320=item $success = $client->query ($flags, "text", \&cb)
1909 2321
1910Queues a query to the client, calling the given callback with 2322Queues a query to the client, calling the given callback with
1911the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2323the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
… …
1940 # get handled first 2352 # get handled first
1941 my $queue = delete $ns->{query_queue} 2353 my $queue = delete $ns->{query_queue}
1942 or return; # be conservative, not sure how that can happen, but we saw a crash here 2354 or return; # be conservative, not sure how that can happen, but we saw a crash here
1943 2355
1944 (shift @$queue)->[1]->($msg); 2356 (shift @$queue)->[1]->($msg);
2357 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1945 2358
1946 push @{ $ns->{query_queue} }, @$queue; 2359 push @{ $ns->{query_queue} }, @$queue;
1947 2360
1948 if (@{ $ns->{query_queue} } == @$queue) { 2361 if (@{ $ns->{query_queue} } == @$queue) {
1949 if (@$queue) { 2362 if (@$queue) {
… …
2007 2420
2008# here we export the classes and methods available to script code 2421# here we export the classes and methods available to script code
2009 2422
2010=pod 2423=pod
2011 2424
2012The following fucntions and emthods are available within a safe environment: 2425The following functions and methods are available within a safe environment:
2013 2426
2014 cf::object contr pay_amount pay_player map 2427 cf::object contr pay_amount pay_player map
2015 cf::object::player player 2428 cf::object::player player
2016 cf::player peaceful 2429 cf::player peaceful
2017 cf::map trigger 2430 cf::map trigger
… …
2098=back 2511=back
2099 2512
2100=cut 2513=cut
2101 2514
2102############################################################################# 2515#############################################################################
2516# the server's init and main functions
2103 2517
2104=head2 EXTENSION DATABASE SUPPORT 2518sub load_facedata($) {
2519 my ($path) = @_;
2105 2520
2106Crossfire maintains a very simple database for extension use. It can 2521 warn "loading facedata from $path\n";
2107currently store anything that can be serialised using Storable, which
2108excludes objects.
2109 2522
2110The parameter C<$family> should best start with the name of the extension 2523 my $facedata;
2111using it, it should be unique. 2524 0 < aio_load $path, $facedata
2525 or die "$path: $!";
2112 2526
2113=over 4 2527 $facedata = Coro::Storable::thaw $facedata;
2114 2528
2115=item $hashref = cf::db_get $family 2529 $facedata->{version} == 2
2530 or cf::cleanup "$path: version mismatch, cannot proceed.";
2116 2531
2117Return a hashref for use by the extension C<$family>, which can be
2118modified. After modifications, you have to call C<cf::db_dirty> or
2119C<cf::db_sync>.
2120
2121=item $value = cf::db_get $family => $key
2122
2123Returns a single value from the database
2124
2125=item cf::db_put $family => $hashref
2126
2127Stores the given family hashref into the database. Updates are delayed, if
2128you want the data to be synced to disk immediately, use C<cf::db_sync>.
2129
2130=item cf::db_put $family => $key => $value
2131
2132Stores the given C<$value> in the family hash. Updates are delayed, if you
2133want the data to be synced to disk immediately, use C<cf::db_sync>.
2134
2135=item cf::db_dirty
2136
2137Marks the database as dirty, to be updated at a later time.
2138
2139=item cf::db_sync
2140
2141Immediately write the database to disk I<if it is dirty>.
2142
2143=cut
2144
2145our $DB;
2146
2147{
2148 my $path = cf::localdir . "/database.pst";
2149
2150 sub db_load() {
2151 $DB = stat $path ? Storable::retrieve $path : { };
2152 } 2532 {
2533 my $faces = $facedata->{faceinfo};
2153 2534
2154 my $pid; 2535 while (my ($face, $info) = each %$faces) {
2155 2536 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2156 sub db_save() { 2537 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2157 waitpid $pid, 0 if $pid; 2538 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2158 if (0 == ($pid = fork)) { 2539 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2159 $DB->{_meta}{version} = 1; 2540 Coro::cede;
2160 Storable::nstore $DB, "$path~";
2161 rename "$path~", $path;
2162 cf::_exit 0 if defined $pid;
2163 }
2164 }
2165
2166 my $dirty;
2167
2168 sub db_sync() {
2169 db_save if $dirty;
2170 undef $dirty;
2171 }
2172
2173 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2174 db_sync;
2175 });
2176
2177 sub db_dirty() {
2178 $dirty = 1;
2179 $idle->start;
2180 }
2181
2182 sub db_get($;$) {
2183 @_ >= 2
2184 ? $DB->{$_[0]}{$_[1]}
2185 : ($DB->{$_[0]} ||= { })
2186 }
2187
2188 sub db_put($$;$) {
2189 if (@_ >= 3) {
2190 $DB->{$_[0]}{$_[1]} = $_[2];
2191 } else {
2192 $DB->{$_[0]} = $_[1];
2193 }
2194 db_dirty;
2195 }
2196
2197 cf::global->attach (
2198 prio => 10000,
2199 on_cleanup => sub {
2200 db_sync;
2201 }, 2541 }
2202 );
2203}
2204 2542
2205############################################################################# 2543 while (my ($face, $info) = each %$faces) {
2206# the server's main() 2544 next unless $info->{smooth};
2545 my $idx = cf::face::find $face
2546 or next;
2547 if (my $smooth = cf::face::find $info->{smooth}) {
2548 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2549 } else {
2550 warn "smooth face '$info->{smooth}' not found for face '$face'";
2551 }
2552 Coro::cede;
2553 }
2554 }
2555
2556 {
2557 my $anims = $facedata->{animinfo};
2558
2559 while (my ($anim, $info) = each %$anims) {
2560 cf::anim::set $anim, $info->{frames}, $info->{facings};
2561 Coro::cede;
2562 }
2563
2564 cf::anim::invalidate_all; # d'oh
2565 }
2566
2567 1
2568}
2569
2570sub reload_regions {
2571 load_resource_file "$MAPDIR/regions"
2572 or die "unable to load regions file\n";
2573}
2574
2575sub reload_facedata {
2576 load_facedata "$DATADIR/facedata"
2577 or die "unable to load facedata\n";
2578}
2579
2580sub reload_archetypes {
2581 load_resource_file "$DATADIR/archetypes"
2582 or die "unable to load archetypes\n";
2583}
2584
2585sub reload_treasures {
2586 load_resource_file "$DATADIR/treasures"
2587 or die "unable to load treasurelists\n";
2588}
2589
2590sub reload_resources {
2591 warn "reloading resource files...\n";
2592
2593 reload_regions;
2594 reload_facedata;
2595 #reload_archetypes;#d#
2596 reload_archetypes;
2597 reload_treasures;
2598
2599 warn "finished reloading resource files\n";
2600}
2601
2602sub init {
2603 reload_resources;
2604}
2207 2605
2208sub cfg_load { 2606sub cfg_load {
2209 open my $fh, "<:utf8", cf::confdir . "/config" 2607 open my $fh, "<:utf8", "$CONFDIR/config"
2210 or return; 2608 or return;
2211 2609
2212 local $/; 2610 local $/;
2213 *CFG = YAML::Syck::Load <$fh>; 2611 *CFG = YAML::Syck::Load <$fh>;
2214 2612
… …
2234 Event::one_event; 2632 Event::one_event;
2235 })->prio (Coro::PRIO_MAX); 2633 })->prio (Coro::PRIO_MAX);
2236 }; 2634 };
2237 2635
2238 cfg_load; 2636 cfg_load;
2239 db_load; 2637 db_init;
2240 load_extensions; 2638 load_extensions;
2639
2640 $TICK_WATCHER->start;
2241 Event::loop; 2641 Event::loop;
2242} 2642}
2243 2643
2244############################################################################# 2644#############################################################################
2245# initialisation and cleanup 2645# initialisation and cleanup
2246 2646
2247# install some emergency cleanup handlers 2647# install some emergency cleanup handlers
2248BEGIN { 2648BEGIN {
2249 for my $signal (qw(INT HUP TERM)) { 2649 for my $signal (qw(INT HUP TERM)) {
2250 Event->signal ( 2650 Event->signal (
2651 reentrant => 0,
2251 data => WF_AUTOCANCEL, 2652 data => WF_AUTOCANCEL,
2252 signal => $signal, 2653 signal => $signal,
2654 prio => 0,
2253 cb => sub { 2655 cb => sub {
2254 cf::cleanup "SIG$signal"; 2656 cf::cleanup "SIG$signal";
2255 }, 2657 },
2256 ); 2658 );
2257 } 2659 }
2660}
2661
2662sub write_runtime {
2663 my $runtime = "$LOCALDIR/runtime";
2664
2665 # first touch the runtime file to show we are still running:
2666 # the fsync below can take a very very long time.
2667
2668 IO::AIO::aio_utime $runtime, undef, undef;
2669
2670 my $guard = cf::lock_acquire "write_runtime";
2671
2672 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2673 or return;
2674
2675 my $value = $cf::RUNTIME + 90 + 10;
2676 # 10 is the runtime save interval, for a monotonic clock
2677 # 60 allows for the watchdog to kill the server.
2678
2679 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2680 and return;
2681
2682 # always fsync - this file is important
2683 aio_fsync $fh
2684 and return;
2685
2686 # touch it again to show we are up-to-date
2687 aio_utime $fh, undef, undef;
2688
2689 close $fh
2690 or return;
2691
2692 aio_rename "$runtime~", $runtime
2693 and return;
2694
2695 warn "runtime file written.\n";
2696
2697 1
2258} 2698}
2259 2699
2260sub emergency_save() { 2700sub emergency_save() {
2261 my $freeze_guard = cf::freeze_mainloop; 2701 my $freeze_guard = cf::freeze_mainloop;
2262 2702
… …
2279 my $map = $cf::MAP{$path} or next; 2719 my $map = $cf::MAP{$path} or next;
2280 $map->valid or next; 2720 $map->valid or next;
2281 $map->save; 2721 $map->save;
2282 } 2722 }
2283 warn "end emergency map save\n"; 2723 warn "end emergency map save\n";
2724
2725 warn "begin emergency database checkpoint\n";
2726 BDB::db_env_txn_checkpoint $DB_ENV;
2727 warn "end emergency database checkpoint\n";
2284 }; 2728 };
2285 2729
2286 warn "leave emergency perl save\n"; 2730 warn "leave emergency perl save\n";
2287} 2731}
2288 2732
2733sub post_cleanup {
2734 my ($make_core) = @_;
2735
2736 warn Carp::longmess "post_cleanup backtrace"
2737 if $make_core;
2738}
2739
2289sub reload() { 2740sub do_reload_perl() {
2290 # can/must only be called in main 2741 # can/must only be called in main
2291 if ($Coro::current != $Coro::main) { 2742 if ($Coro::current != $Coro::main) {
2292 warn "can only reload from main coroutine\n"; 2743 warn "can only reload from main coroutine";
2293 return; 2744 return;
2294 } 2745 }
2295 2746
2296 warn "reloading..."; 2747 warn "reloading...";
2297 2748
2298 warn "freezing server"; 2749 warn "entering sync_job";
2299 my $guard = freeze_mainloop; 2750
2751 cf::sync_job {
2752 cf::write_runtime; # external watchdog should not bark
2300 cf::emergency_save; 2753 cf::emergency_save;
2754 cf::write_runtime; # external watchdog should not bark
2301 2755
2302 warn "sync database to disk"; 2756 warn "syncing database to disk";
2303 cf::db_sync; 2757 BDB::db_env_txn_checkpoint $DB_ENV;
2304 IO::AIO::flush;
2305 2758
2306 eval {
2307 # if anything goes wrong in here, we should simply crash as we already saved 2759 # if anything goes wrong in here, we should simply crash as we already saved
2308 2760
2309 warn "cancel all watchers"; 2761 warn "cancelling all WF_AUTOCANCEL watchers";
2310 for (Event::all_watchers) { 2762 for (Event::all_watchers) {
2311 $_->cancel if $_->data & WF_AUTOCANCEL; 2763 $_->cancel if $_->data & WF_AUTOCANCEL;
2312 } 2764 }
2313 2765
2766 warn "flushing outstanding aio requests";
2767 for (;;) {
2768 BDB::flush;
2769 IO::AIO::flush;
2770 Coro::cede;
2771 last unless IO::AIO::nreqs || BDB::nreqs;
2772 warn "iterate...";
2773 }
2774
2775 ++$RELOAD;
2776
2314 warn "cancel all extension coros"; 2777 warn "cancelling all extension coros";
2315 $_->cancel for values %EXT_CORO; 2778 $_->cancel for values %EXT_CORO;
2316 %EXT_CORO = (); 2779 %EXT_CORO = ();
2317 2780
2318 warn "remove commands"; 2781 warn "removing commands";
2319 %COMMAND = (); 2782 %COMMAND = ();
2320 2783
2321 warn "remove ext commands"; 2784 warn "removing ext commands";
2322 %EXTCMD = (); 2785 %EXTCMD = ();
2323 2786
2324 warn "unload/nuke all extensions"; 2787 warn "unloading/nuking all extensions";
2325 for my $pkg (@EXTS) { 2788 for my $pkg (@EXTS) {
2326 warn "... unloading $pkg"; 2789 warn "... unloading $pkg";
2327 2790
2328 if (my $cb = $pkg->can ("unload")) { 2791 if (my $cb = $pkg->can ("unload")) {
2329 eval { 2792 eval {
… …
2334 2797
2335 warn "... nuking $pkg"; 2798 warn "... nuking $pkg";
2336 Symbol::delete_package $pkg; 2799 Symbol::delete_package $pkg;
2337 } 2800 }
2338 2801
2339 warn "unload all perl modules loaded from $LIBDIR"; 2802 warn "unloading all perl modules loaded from $LIBDIR";
2340 while (my ($k, $v) = each %INC) { 2803 while (my ($k, $v) = each %INC) {
2341 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2804 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2342 2805
2343 warn "removing <$k>"; 2806 warn "... unloading $k";
2344 delete $INC{$k}; 2807 delete $INC{$k};
2345 2808
2346 $k =~ s/\.pm$//; 2809 $k =~ s/\.pm$//;
2347 $k =~ s/\//::/g; 2810 $k =~ s/\//::/g;
2348 2811
… …
2351 } 2814 }
2352 2815
2353 Symbol::delete_package $k; 2816 Symbol::delete_package $k;
2354 } 2817 }
2355 2818
2356 warn "get rid of safe::, as good as possible"; 2819 warn "getting rid of safe::, as good as possible";
2357 Symbol::delete_package "safe::$_" 2820 Symbol::delete_package "safe::$_"
2358 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2821 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2359 2822
2360 warn "unload cf.pm \"a bit\""; 2823 warn "unloading cf.pm \"a bit\"";
2361 delete $INC{"cf.pm"}; 2824 delete $INC{"cf.pm"};
2825 delete $INC{"cf/pod.pm"};
2362 2826
2363 # don't, removes xs symbols, too, 2827 # don't, removes xs symbols, too,
2364 # and global variables created in xs 2828 # and global variables created in xs
2365 #Symbol::delete_package __PACKAGE__; 2829 #Symbol::delete_package __PACKAGE__;
2366 2830
2831 warn "unload completed, starting to reload now";
2832
2367 warn "reloading cf.pm"; 2833 warn "reloading cf.pm";
2368 require cf; 2834 require cf;
2369 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2835 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2370 2836
2371 warn "load config and database again"; 2837 warn "loading config and database again";
2372 cf::cfg_load; 2838 cf::cfg_load;
2373 cf::db_load;
2374 2839
2375 warn "load extensions"; 2840 warn "loading extensions";
2376 cf::load_extensions; 2841 cf::load_extensions;
2377 2842
2378 warn "reattach attachments to objects/players"; 2843 warn "reattaching attachments to objects/players";
2379 _global_reattach; 2844 _global_reattach; # objects, sockets
2380 warn "reattach attachments to maps"; 2845 warn "reattaching attachments to maps";
2381 reattach $_ for values %MAP; 2846 reattach $_ for values %MAP;
2382 }; 2847 warn "reattaching attachments to players";
2848 reattach $_ for values %PLAYER;
2383 2849
2384 if ($@) { 2850 warn "leaving sync_job";
2851
2852 1
2853 } or do {
2385 warn $@; 2854 warn $@;
2386 warn "error while reloading, exiting."; 2855 warn "error while reloading, exiting.";
2387 exit 1; 2856 exit 1;
2388 } 2857 };
2389 2858
2390 warn "reloaded"; 2859 warn "reloaded";
2391}; 2860};
2392 2861
2393our $RELOAD_WATCHER; # used only during reload 2862our $RELOAD_WATCHER; # used only during reload
2394 2863
2864sub reload_perl() {
2865 # doing reload synchronously and two reloads happen back-to-back,
2866 # coro crashes during coro_state_free->destroy here.
2867
2868 $RELOAD_WATCHER ||= Event->timer (
2869 reentrant => 0,
2870 after => 0,
2871 data => WF_AUTOCANCEL,
2872 cb => sub {
2873 do_reload_perl;
2874 undef $RELOAD_WATCHER;
2875 },
2876 );
2877}
2878
2395register_command "reload" => sub { 2879register_command "reload" => sub {
2396 my ($who, $arg) = @_; 2880 my ($who, $arg) = @_;
2397 2881
2398 if ($who->flag (FLAG_WIZ)) { 2882 if ($who->flag (FLAG_WIZ)) {
2399 $who->message ("reloading server."); 2883 $who->message ("reloading server.");
2400 2884 async { reload_perl };
2401 # doing reload synchronously and two reloads happen back-to-back,
2402 # coro crashes during coro_state_free->destroy here.
2403
2404 $RELOAD_WATCHER ||= Event->timer (after => 0, data => WF_AUTOCANCEL, cb => sub {
2405 reload;
2406 undef $RELOAD_WATCHER;
2407 });
2408 } 2885 }
2409}; 2886};
2410 2887
2411unshift @INC, $LIBDIR; 2888unshift @INC, $LIBDIR;
2412 2889
2890my $bug_warning = 0;
2891
2892our @WAIT_FOR_TICK;
2893our @WAIT_FOR_TICK_BEGIN;
2894
2895sub wait_for_tick {
2896 return unless $TICK_WATCHER->is_active;
2897 return if $Coro::current == $Coro::main;
2898
2899 my $signal = new Coro::Signal;
2900 push @WAIT_FOR_TICK, $signal;
2901 $signal->wait;
2902}
2903
2904sub wait_for_tick_begin {
2905 return unless $TICK_WATCHER->is_active;
2906 return if $Coro::current == $Coro::main;
2907
2908 my $signal = new Coro::Signal;
2909 push @WAIT_FOR_TICK_BEGIN, $signal;
2910 $signal->wait;
2911}
2912
2913 my $min = 1e6;#d#
2914 my $avg = 10;
2413$TICK_WATCHER = Event->timer ( 2915$TICK_WATCHER = Event->timer (
2414 reentrant => 0, 2916 reentrant => 0,
2917 parked => 1,
2415 prio => 0, 2918 prio => 0,
2416 at => $NEXT_TICK || $TICK, 2919 at => $NEXT_TICK || $TICK,
2417 data => WF_AUTOCANCEL, 2920 data => WF_AUTOCANCEL,
2418 cb => sub { 2921 cb => sub {
2922 if ($Coro::current != $Coro::main) {
2923 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2924 unless ++$bug_warning > 10;
2925 return;
2926 }
2927
2419 $NOW = Event::time; 2928 $NOW = $tick_start = Event::time;
2420 2929
2421 cf::server_tick; # one server iteration 2930 cf::server_tick; # one server iteration
2931
2932 0 && sync_job {#d#
2933 for(1..10) {
2934 my $t = Event::time;
2935 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2936 or die;
2937
2938 $map->width (50);
2939 $map->height (50);
2940 $map->alloc;
2941 $map->_load_objects ("/tmp/x.map", 1);
2942 my $t = Event::time - $t;
2943
2944 #next unless $t < 0.0013;#d#
2945 if ($t < $min) {
2946 $min = $t;
2947 }
2948 $avg = $avg * 0.99 + $t * 0.01;
2949 }
2950 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2951 exit 0;
2952 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2953 };
2954
2422 $RUNTIME += $TICK; 2955 $RUNTIME += $TICK;
2423 $NEXT_TICK += $TICK; 2956 $NEXT_TICK += $TICK;
2424 2957
2425 $WAIT_FOR_TICK->broadcast; 2958 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2426 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 2959 $NEXT_RUNTIME_WRITE = $NOW + 10;
2960 Coro::async_pool {
2961 write_runtime
2962 or warn "ERROR: unable to write runtime file: $!";
2963 };
2964 }
2965
2966# my $AFTER = Event::time;
2967# warn $AFTER - $NOW;#d#
2968
2969 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2970 $sig->send;
2971 }
2972 while (my $sig = shift @WAIT_FOR_TICK) {
2973 $sig->send;
2974 }
2975
2976 $NOW = Event::time;
2427 2977
2428 # if we are delayed by four ticks or more, skip them all 2978 # if we are delayed by four ticks or more, skip them all
2429 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2979 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2430 2980
2431 $TICK_WATCHER->at ($NEXT_TICK); 2981 $TICK_WATCHER->at ($NEXT_TICK);
2432 $TICK_WATCHER->start; 2982 $TICK_WATCHER->start;
2983
2984 $LOAD = ($NOW - $tick_start) / $TICK;
2985 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2986
2987 _post_tick;
2988
2989
2433 }, 2990 },
2434); 2991);
2435 2992
2993{
2994 BDB::max_poll_time $TICK * 0.1;
2995 $BDB_POLL_WATCHER = Event->io (
2996 reentrant => 0,
2997 fd => BDB::poll_fileno,
2998 poll => 'r',
2999 prio => 0,
3000 data => WF_AUTOCANCEL,
3001 cb => \&BDB::poll_cb,
3002 );
3003 BDB::min_parallel 8;
3004
3005 BDB::set_sync_prepare {
3006 my $status;
3007 my $current = $Coro::current;
3008 (
3009 sub {
3010 $status = $!;
3011 $current->ready; undef $current;
3012 },
3013 sub {
3014 Coro::schedule while defined $current;
3015 $! = $status;
3016 },
3017 )
3018 };
3019
3020 unless ($DB_ENV) {
3021 $DB_ENV = BDB::db_env_create;
3022
3023 cf::sync_job {
3024 eval {
3025 BDB::db_env_open
3026 $DB_ENV,
3027 $BDBDIR,
3028 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3029 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3030 0666;
3031
3032 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3033
3034 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3035 $DB_ENV->set_lk_detect;
3036 };
3037
3038 cf::cleanup "db_env_open(db): $@" if $@;
3039 };
3040 }
3041}
3042
3043{
3044 IO::AIO::min_parallel 8;
3045
3046 undef $Coro::AIO::WATCHER;
2436IO::AIO::max_poll_time $TICK * 0.2; 3047 IO::AIO::max_poll_time $TICK * 0.1;
2437
2438$AIO_POLL_WATCHER = Event->io ( 3048 $AIO_POLL_WATCHER = Event->io (
2439 fd => IO::AIO::poll_fileno, 3049 reentrant => 0,
2440 poll => 'r',
2441 prio => 5,
2442 data => WF_AUTOCANCEL,
2443 cb => \&IO::AIO::poll_cb,
2444);
2445
2446$WRITE_RUNTIME_WATCHER = Event->timer (
2447 data => WF_AUTOCANCEL, 3050 data => WF_AUTOCANCEL,
2448 after => 0, 3051 fd => IO::AIO::poll_fileno,
2449 interval => 10, 3052 poll => 'r',
2450 cb => sub { 3053 prio => 6,
2451 (Coro::unblock_sub { 3054 cb => \&IO::AIO::poll_cb,
2452 write_runtime 3055 );
2453 or warn "ERROR: unable to write runtime file: $!"; 3056}
3057
3058my $_log_backtrace;
3059
3060sub _log_backtrace {
3061 my ($msg, @addr) = @_;
3062
3063 $msg =~ s/\n//;
3064
3065 # limit the # of concurrent backtraces
3066 if ($_log_backtrace < 2) {
3067 ++$_log_backtrace;
3068 async {
3069 my @bt = fork_call {
3070 @addr = map { sprintf "%x", $_ } @addr;
3071 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3072 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3073 or die "addr2line: $!";
3074
3075 my @funcs;
3076 my @res = <$fh>;
3077 chomp for @res;
3078 while (@res) {
3079 my ($func, $line) = splice @res, 0, 2, ();
3080 push @funcs, "[$func] $line";
3081 }
3082
3083 @funcs
3084 };
3085
3086 LOG llevInfo, "[ABT] $msg\n";
3087 LOG llevInfo, "[ABT] $_\n" for @bt;
3088 --$_log_backtrace;
2454 })->(); 3089 };
3090 } else {
3091 LOG llevInfo, "[ABT] $msg\n";
3092 LOG llevInfo, "[ABT] [suppressed]\n";
2455 }, 3093 }
2456); 3094}
3095
3096# load additional modules
3097use cf::pod;
2457 3098
2458END { cf::emergency_save } 3099END { cf::emergency_save }
2459 3100
24601 31011
2461 3102

Diff Legend

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