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.169 by root, Sun Jan 14 01:09:46 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.3 (); 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
… …
503our @CB_TYPE = (); # registry for type (cf-object class) based events 702our @CB_TYPE = (); # registry for type (cf-object class) based events
504our @CB_MAP = (); 703our @CB_MAP = ();
505 704
506my %attachment; 705my %attachment;
507 706
707sub cf::attachable::thawer_merge {
708 # simply override everything except _meta
709 local $_[0]{_meta};
710 %{$_[0]} = %{$_[1]};
711}
712
508sub _attach_cb($$$$) { 713sub _attach_cb($$$$) {
509 my ($registry, $event, $prio, $cb) = @_; 714 my ($registry, $event, $prio, $cb) = @_;
510 715
511 use sort 'stable'; 716 use sort 'stable';
512 717
… …
546 $registry = $CB_TYPE[$object_type] ||= []; 751 $registry = $CB_TYPE[$object_type] ||= [];
547 752
548 } elsif ($type eq "subtype") { 753 } elsif ($type eq "subtype") {
549 defined $object_type or Carp::croak "subtype specified without type"; 754 defined $object_type or Carp::croak "subtype specified without type";
550 my $object_subtype = shift @arg; 755 my $object_subtype = shift @arg;
551 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 756 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
552 757
553 } elsif ($type eq "package") { 758 } elsif ($type eq "package") {
554 my $pkg = shift @arg; 759 my $pkg = shift @arg;
555 760
556 while (my ($name, $id) = each %cb_id) { 761 while (my ($name, $id) = each %cb_id) {
… …
585 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
586 } 791 }
587 792
588 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
589 } else { 794 } else {
590 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
591 } 796 }
592 797
593 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
594} 799}
595 800
… …
597 if (ref $_[0]) { 802 if (ref $_[0]) {
598 _object_attach @_; 803 _object_attach @_;
599 } else { 804 } else {
600 _attach shift->_attach_registry, @_; 805 _attach shift->_attach_registry, @_;
601 } 806 }
807 _recalc_want;
602}; 808};
603 809
604# all those should be optimised 810# all those should be optimised
605sub cf::attachable::detach { 811sub cf::attachable::detach {
606 my ($obj, $name) = @_; 812 my ($obj, $name) = @_;
… …
609 delete $obj->{_attachment}{$name}; 815 delete $obj->{_attachment}{$name};
610 reattach ($obj); 816 reattach ($obj);
611 } else { 817 } else {
612 Carp::croak "cannot, currently, detach class attachments"; 818 Carp::croak "cannot, currently, detach class attachments";
613 } 819 }
820 _recalc_want;
614}; 821};
615 822
616sub cf::attachable::attached { 823sub cf::attachable::attached {
617 my ($obj, $name) = @_; 824 my ($obj, $name) = @_;
618 825
… …
741 $filename, length $$rdata, scalar @$objs; 948 $filename, length $$rdata, scalar @$objs;
742 949
743 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 950 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
744 chmod SAVE_MODE, $fh; 951 chmod SAVE_MODE, $fh;
745 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 952 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
746 aio_fsync $fh; 953 aio_fsync $fh if $cf::USE_FSYNC;
747 close $fh; 954 close $fh;
748 955
749 if (@$objs) { 956 if (@$objs) {
750 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) {
751 chmod SAVE_MODE, $fh; 958 chmod SAVE_MODE, $fh;
752 my $data = Storable::nfreeze { version => 1, objs => $objs }; 959 my $data = Storable::nfreeze { version => 1, objs => $objs };
753 aio_write $fh, 0, (length $data), $data, 0; 960 aio_write $fh, 0, (length $data), $data, 0;
754 aio_fsync $fh; 961 aio_fsync $fh if $cf::USE_FSYNC;
755 close $fh; 962 close $fh;
756 aio_rename "$filename.pst~", "$filename.pst"; 963 aio_rename "$filename.pst~", "$filename.pst";
757 } 964 }
758 } else { 965 } else {
759 aio_unlink "$filename.pst"; 966 aio_unlink "$filename.pst";
… …
791 or return; 998 or return;
792 $av = eval { (Storable::thaw $av)->{objs} }; 999 $av = eval { (Storable::thaw $av)->{objs} };
793 } 1000 }
794 1001
795 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
796 $filename, length $data, scalar @{$av || []};#d# 1003 $filename, length $data, scalar @{$av || []};
797 return ($data, $av); 1004 return ($data, $av);
798} 1005}
1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
799 1012
800############################################################################# 1013#############################################################################
801# command handling &c 1014# command handling &c
802 1015
803=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
… …
816 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
817} 1030}
818 1031
819=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
820 1033
821Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
822 1035
823If 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
824called. 1037called.
825 1038
826=cut 1039=cut
… …
861 1074
862 cf::override; 1075 cf::override;
863 }, 1076 },
864); 1077);
865 1078
866sub load_extension {
867 my ($path) = @_;
868
869 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
870 my $base = $1;
871 my $pkg = $1;
872 $pkg =~ s/[^[:word:]]/_/g;
873 $pkg = "ext::$pkg";
874
875 warn "... loading '$path' into '$pkg'\n";
876
877 open my $fh, "<:utf8", $path
878 or die "$path: $!";
879
880 my $source =
881 "package $pkg; use strict; use utf8;\n"
882 . "#line 1 \"$path\"\n{\n"
883 . (do { local $/; <$fh> })
884 . "\n};\n1";
885
886 unless (eval $source) {
887 my $msg = $@ ? "$path: $@\n"
888 : "extension disabled.\n";
889 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
890 warn $@;
891 warn "mandatory extension failed to load, exiting.\n";
892 exit 1;
893 }
894 die $@;
895 }
896
897 push @EXTS, $pkg;
898}
899
900sub load_extensions { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
901 for my $ext (<$LIBDIR/*.ext>) { 1083 for my $path (<$LIBDIR/*.ext>) {
902 next unless -r $ext; 1084 next unless -r $path;
903 eval { 1085
904 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;
905 1 1143 }
906 } or warn "$ext not loaded: $@"; 1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
907 } 1149 };
908} 1150}
909 1151
910############################################################################# 1152#############################################################################
911 1153
1154=back
1155
912=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
913 1157
914Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
915 1159
916=cut 1160=cut
… …
928Returns the given player object, loading it if necessary (might block). 1172Returns the given player object, loading it if necessary (might block).
929 1173
930=cut 1174=cut
931 1175
932sub playerdir($) { 1176sub playerdir($) {
933 cf::localdir 1177 "$PLAYERDIR/"
934 . "/"
935 . cf::playerdir
936 . "/"
937 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1178 . (ref $_[0] ? $_[0]->ob->name : $_[0])
938} 1179}
939 1180
940sub path($) { 1181sub path($) {
941 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1182 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
942 1183
943 (playerdir $login) . "/$login.pl" 1184 (playerdir $login) . "/playerdata"
944} 1185}
945 1186
946sub find_active($) { 1187sub find_active($) {
947 $cf::PLAYER{$_[0]} 1188 $cf::PLAYER{$_[0]}
948 and $cf::PLAYER{$_[0]}->active 1189 and $cf::PLAYER{$_[0]}->active
… …
951 1192
952sub exists($) { 1193sub exists($) {
953 my ($login) = @_; 1194 my ($login) = @_;
954 1195
955 $cf::PLAYER{$login} 1196 $cf::PLAYER{$login}
956 or cf::sync_job { !aio_stat $login } 1197 or cf::sync_job { !aio_stat path $login }
957} 1198}
958 1199
959sub find($) { 1200sub find($) {
960 return $cf::PLAYER{$_[0]} || do { 1201 return $cf::PLAYER{$_[0]} || do {
961 my $login = $_[0]; 1202 my $login = $_[0];
962 1203
963 my $guard = cf::lock_acquire "user_find:$login"; 1204 my $guard = cf::lock_acquire "user_find:$login";
964 1205
965 $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
966 my $pl = load_pl path $login 1214 my $pl = load_pl path $login
967 or return; 1215 or return;
968 $cf::PLAYER{$login} = $pl 1216 $cf::PLAYER{$login} = $pl
969 } 1217 }
970 } 1218 }
… …
1007 1255
1008=cut 1256=cut
1009 1257
1010sub quit_character { 1258sub quit_character {
1011 my ($pl) = @_; 1259 my ($pl) = @_;
1260
1261 my $name = $pl->ob->name;
1012 1262
1013 $pl->{deny_save} = 1; 1263 $pl->{deny_save} = 1;
1014 $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
1015 1265
1016 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1266 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1021 my $path = playerdir $pl; 1271 my $path = playerdir $pl;
1022 my $temp = "$path~$cf::RUNTIME~deleting~"; 1272 my $temp = "$path~$cf::RUNTIME~deleting~";
1023 aio_rename $path, $temp; 1273 aio_rename $path, $temp;
1024 delete $cf::PLAYER{$pl->ob->name}; 1274 delete $cf::PLAYER{$pl->ob->name};
1025 $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
1026 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;
1027} 1297}
1028 1298
1029=item cf::player::list_logins 1299=item cf::player::list_logins
1030 1300
1031Returns 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
1032while and may block, so not sync_job-capable, ever. 1302while and may block, so not sync_job-capable, ever.
1033 1303
1034=cut 1304=cut
1035 1305
1036sub list_logins { 1306sub list_logins {
1037 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1307 my $dirs = aio_readdir $PLAYERDIR
1038 or return []; 1308 or return [];
1039 1309
1040 my @logins; 1310 my @logins;
1041 1311
1042 for my $login (@$dirs) { 1312 for my $login (@$dirs) {
… …
1059=cut 1329=cut
1060 1330
1061sub maps($) { 1331sub maps($) {
1062 my ($pl) = @_; 1332 my ($pl) = @_;
1063 1333
1334 $pl = ref $pl ? $pl->ob->name : $pl;
1335
1064 my $files = aio_readdir playerdir $pl 1336 my $files = aio_readdir playerdir $pl
1065 or return; 1337 or return;
1066 1338
1067 my @paths; 1339 my @paths;
1068 1340
1069 for (@$files) { 1341 for (@$files) {
1070 utf8::decode $_; 1342 utf8::decode $_;
1071 next if /\.(?:pl|pst)$/; 1343 next if /\.(?:pl|pst)$/;
1072 next unless /^$PATH_SEP/o; 1344 next unless /^$PATH_SEP/o;
1073 1345
1074 s/\.map$//; 1346 push @paths, cf::map::normalise "~$pl/$_";
1075 push @paths, "~" . $pl->ob->name . "/" . $_;
1076 } 1347 }
1077 1348
1078 \@paths 1349 \@paths
1079} 1350}
1080 1351
1081=item $player->ext_reply ($msgid, $msgtype, %msg) 1352=item $player->ext_reply ($msgid, %msg)
1082 1353
1083Sends an ext reply to the player. 1354Sends an ext reply to the player.
1084 1355
1085=cut 1356=cut
1086 1357
1087sub ext_reply($$$%) { 1358sub ext_reply($$%) {
1088 my ($self, $id, %msg) = @_; 1359 my ($self, $id, %msg) = @_;
1089 1360
1090 $msg{msgid} = $id; 1361 $msg{msgid} = $id;
1091 1362
1092 $self->send ("ext " . cf::to_json \%msg); 1363 $self->send ("ext " . cf::to_json \%msg);
1093} 1364}
1094 1365
1095package 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}
1096 1406
1097=back 1407=back
1098
1099 1408
1100=head3 cf::map 1409=head3 cf::map
1101 1410
1102=over 4 1411=over 4
1103 1412
… …
1107 1416
1108use Fcntl; 1417use Fcntl;
1109use Coro::AIO; 1418use Coro::AIO;
1110 1419
1111use overload 1420use overload
1112 '""' => \&as_string; 1421 '""' => \&as_string,
1422 fallback => 1;
1113 1423
1114our $MAX_RESET = 3600; 1424our $MAX_RESET = 3600;
1115our $DEFAULT_RESET = 3000; 1425our $DEFAULT_RESET = 3000;
1116 1426
1117sub generate_random_map { 1427sub generate_random_map {
1118 my ($self, $rmp) = @_; 1428 my ($self, $rmp) = @_;
1119
1120 # mit "rum" bekleckern, nicht 1429 # mit "rum" bekleckern, nicht
1121 $self->_create_random_map ( 1430 $self->_create_random_map (
1122 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1431 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1123 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1432 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1124 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1433 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
… …
1131 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1440 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1132 (cf::region::find $rmp->{region}), $rmp->{custom} 1441 (cf::region::find $rmp->{region}), $rmp->{custom}
1133 ) 1442 )
1134} 1443}
1135 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
1136sub register { 1453sub register {
1137 my (undef, $regex) = @_; 1454 my (undef, $regex, $prio) = @_;
1138 my $pkg = caller; 1455 my $pkg = caller;
1139 1456
1140 no strict; 1457 no strict;
1141 push @{"$pkg\::ISA"}, __PACKAGE__; 1458 push @{"$pkg\::ISA"}, __PACKAGE__;
1142 1459
1143 $EXT_MAP{$pkg} = qr<$regex>; 1460 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1144} 1461}
1145 1462
1146# also paths starting with '/' 1463# also paths starting with '/'
1147$EXT_MAP{"cf::map"} = qr{^(?=/)}; 1464$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1465
1466sub thawer_merge {
1467 my ($self, $merge) = @_;
1468
1469 # we have to keep some variables in memory intact
1470 local $self->{path};
1471 local $self->{load_path};
1472
1473 $self->SUPER::thawer_merge ($merge);
1474}
1148 1475
1149sub normalise { 1476sub normalise {
1150 my ($path, $base) = @_; 1477 my ($path, $base) = @_;
1478
1479 $path = "$path"; # make sure its a string
1480
1481 $path =~ s/\.map$//;
1151 1482
1152 # map plan: 1483 # map plan:
1153 # 1484 #
1154 # /! non-realised random map exit (special hack!) 1485 # /! non-realised random map exit (special hack!)
1155 # {... are special paths that are not being touched 1486 # {... are special paths that are not being touched
… …
1183 1514
1184 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
1185 1516
1186 $path = normalise $path, $base; 1517 $path = normalise $path, $base;
1187 1518
1188 for my $pkg (keys %EXT_MAP) { 1519 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1189 if ($path =~ $EXT_MAP{$pkg}) { 1520 if ($path =~ $EXT_MAP{$pkg}[1]) {
1190 my $self = bless cf::map::new, $pkg; 1521 my $self = bless cf::map::new, $pkg;
1191 $self->{path} = $path; $self->path ($path); 1522 $self->{path} = $path; $self->path ($path);
1192 $self->init; # pass $1 etc. 1523 $self->init; # pass $1 etc.
1193 return $self; 1524 return $self;
1194 } 1525 }
1195 } 1526 }
1196 1527
1197 Carp::carp "unable to resolve path '$path'."; 1528 Carp::carp "unable to resolve path '$path' (base '$base').";
1198 () 1529 ()
1199} 1530}
1200 1531
1201sub init { 1532sub init {
1202 my ($self) = @_; 1533 my ($self) = @_;
… …
1217 1548
1218# the original (read-only) location 1549# the original (read-only) location
1219sub load_path { 1550sub load_path {
1220 my ($self) = @_; 1551 my ($self) = @_;
1221 1552
1222 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1553 "$MAPDIR/$self->{path}.map"
1223} 1554}
1224 1555
1225# the temporary/swap location 1556# the temporary/swap location
1226sub save_path { 1557sub save_path {
1227 my ($self) = @_; 1558 my ($self) = @_;
1228 1559
1229 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1560 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1230 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path 1561 "$TMPDIR/$path.map"
1231} 1562}
1232 1563
1233# the unique path, undef == no special unique path 1564# the unique path, undef == no special unique path
1234sub uniq_path { 1565sub uniq_path {
1235 my ($self) = @_; 1566 my ($self) = @_;
1236 1567
1237 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1568 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1238 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1569 "$UNIQUEDIR/$path"
1239} 1570}
1240 1571
1241# and all this just because we cannot iterate over 1572# and all this just because we cannot iterate over
1242# all maps in C++... 1573# all maps in C++...
1243sub change_all_map_light { 1574sub change_all_map_light {
… …
1245 1576
1246 $_->change_map_light ($change) 1577 $_->change_map_light ($change)
1247 for grep $_->outdoor, values %cf::MAP; 1578 for grep $_->outdoor, values %cf::MAP;
1248} 1579}
1249 1580
1581sub decay_objects {
1582 my ($self) = @_;
1583
1584 return if $self->{deny_reset};
1585
1586 $self->do_decay_objects;
1587}
1588
1250sub unlink_save { 1589sub unlink_save {
1251 my ($self) = @_; 1590 my ($self) = @_;
1252 1591
1253 utf8::encode (my $save = $self->save_path); 1592 utf8::encode (my $save = $self->save_path);
1254 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save; 1593 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1255 IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst"; 1594 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1256} 1595}
1257 1596
1258sub load_header_from($) { 1597sub load_header_from($) {
1259 my ($self, $path) = @_; 1598 my ($self, $path) = @_;
1260 1599
1261 utf8::encode $path; 1600 utf8::encode $path;
1262 aio_open $path, O_RDONLY, 0 1601 #aio_open $path, O_RDONLY, 0
1263 or return; 1602 # or return;
1264 1603
1265 $self->_load_header ($path) 1604 $self->_load_header ($path)
1266 or return; 1605 or return;
1267 1606
1268 $self->{load_path} = $path; 1607 $self->{load_path} = $path;
1269 1608
1270 1 1609 1
1271} 1610}
1272 1611
1273sub load_orig { 1612sub load_header_orig {
1274 my ($self) = @_; 1613 my ($self) = @_;
1275 1614
1276 $self->load_header_from ($self->load_path) 1615 $self->load_header_from ($self->load_path)
1277} 1616}
1278 1617
1279sub load_temp { 1618sub load_header_temp {
1280 my ($self) = @_; 1619 my ($self) = @_;
1281 1620
1282 $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;
1283} 1641}
1284 1642
1285sub load_header { 1643sub load_header {
1286 my ($self) = @_; 1644 my ($self) = @_;
1287 1645
1288 if ($self->load_temp) { 1646 if ($self->load_header_temp) {
1289 $self->last_access ((delete $self->{last_access}) 1647 $self->prepare_temp;
1290 || $cf::RUNTIME); #d#
1291 # safety
1292 $self->{instantiate_time} = $cf::RUNTIME
1293 if $self->{instantiate_time} > $cf::RUNTIME;
1294 } else { 1648 } else {
1295 $self->load_orig 1649 $self->load_header_orig
1296 or return; 1650 or return;
1297 1651 $self->prepare_orig;
1298 $self->{load_original} = 1;
1299 $self->{instantiate_time} = $cf::RUNTIME;
1300 $self->last_access ($cf::RUNTIME);
1301 $self->instantiate;
1302 } 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;
1303 1659
1304 1 1660 1
1305} 1661}
1306 1662
1307sub find; 1663sub find;
… …
1320 $map->{last_save} = $cf::RUNTIME; 1676 $map->{last_save} = $cf::RUNTIME;
1321 1677
1322 $map->load_header 1678 $map->load_header
1323 or return; 1679 or return;
1324 1680
1325 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
1683 #$cf::WAIT_FOR_TICK->wait;
1326 $map->reset; 1684 $map->reset;
1327 undef $guard; 1685 undef $guard;
1328 $map = find $path 1686 return find $path;
1329 or return;
1330 } 1687 }
1331 1688
1332 $cf::MAP{$path} = $map 1689 $cf::MAP{$path} = $map
1333 } 1690 }
1334} 1691}
1692
1693sub pre_load { }
1694sub post_load { }
1335 1695
1336sub load { 1696sub load {
1337 my ($self) = @_; 1697 my ($self) = @_;
1338 1698
1699 local $self->{deny_reset} = 1; # loading can take a long time
1700
1339 my $path = $self->{path}; 1701 my $path = $self->{path};
1702
1703 {
1340 my $guard = cf::lock_acquire "map_load:$path"; 1704 my $guard = cf::lock_acquire "map_load:$path";
1341 1705
1342 return if $self->in_memory != cf::MAP_SWAPPED; 1706 return if $self->in_memory != cf::MAP_SWAPPED;
1343 1707
1344 $self->in_memory (cf::MAP_LOADING); 1708 $self->in_memory (cf::MAP_LOADING);
1345 1709
1346 $self->alloc; 1710 $self->alloc;
1347 $self->_load_objects ($self->{load_path}, 1)
1348 or return;
1349 1711
1350 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1712 $self->pre_load;
1351 if delete $self->{load_original};
1352
1353 if (my $uniq = $self->uniq_path) {
1354 utf8::encode $uniq;
1355 if (aio_open $uniq, O_RDONLY, 0) {
1356 $self->clear_unique_items;
1357 $self->_load_objects ($uniq, 0);
1358 }
1359 }
1360
1361 Coro::cede;
1362
1363 # now do the right thing for maps
1364 $self->link_multipart_objects;
1365
1366 unless ($self->{deny_activate}) {
1367 $self->decay_objects;
1368 $self->fix_auto_apply;
1369 $self->update_buttons;
1370 Coro::cede; 1713 Coro::cede;
1371 $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;
1372 $self->difficulty ($self->estimate_difficulty) 1732 $self->difficulty ($self->estimate_difficulty)
1373 unless $self->difficulty; 1733 unless $self->difficulty;
1374 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;
1375 $self->activate; 1743 $self->activate;
1376 } 1744 }
1377 1745
1378 $self->in_memory (cf::MAP_IN_MEMORY); 1746 $self->in_memory (cf::MAP_IN_MEMORY);
1747 }
1748
1749 $self->post_load;
1379} 1750}
1380 1751
1381sub customise_for { 1752sub customise_for {
1382 my ($self, $ob) = @_; 1753 my ($self, $ob) = @_;
1383 1754
1384 return find "~" . $ob->name . "/" . $self->{path} 1755 return find "~" . $ob->name . "/" . $self->{path}
1385 if $self->per_player; 1756 if $self->per_player;
1757
1758# return find "?party/" . $ob->name . "/" . $self->{path}
1759# if $self->per_party;
1386 1760
1387 $self 1761 $self
1388} 1762}
1389 1763
1390# 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
… …
1422 1796
1423 cf::sync_job { $map->load }; 1797 cf::sync_job { $map->load };
1424} 1798}
1425 1799
1426our %MAP_PREFETCH; 1800our %MAP_PREFETCH;
1427our $MAP_PREFETCHER = Coro::async { 1801our $MAP_PREFETCHER = undef;
1428 while () {
1429 for my $path (keys %MAP_PREFETCH) {
1430 my $map = find $path
1431 or next;
1432 $map->load;
1433
1434 delete $MAP_PREFETCH{$path};
1435 }
1436 Coro::schedule;
1437 }
1438};
1439 1802
1440sub find_async { 1803sub find_async {
1441 my ($path, $origin) = @_; 1804 my ($path, $origin) = @_;
1442 1805
1443 $path = normalise $path, $origin && $origin->{path}; 1806 $path = normalise $path, $origin && $origin->{path};
1444 1807
1445 if (my $map = $cf::MAP{$path}) { 1808 if (my $map = $cf::MAP{$path}) {
1446 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1809 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1447 } 1810 }
1448 1811
1449 $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 };
1450 $MAP_PREFETCHER->ready; 1825 $MAP_PREFETCHER->prio (6);
1451 1826
1452 () 1827 ()
1453} 1828}
1454 1829
1455sub save { 1830sub save {
… …
1500 1875
1501sub reset_at { 1876sub reset_at {
1502 my ($self) = @_; 1877 my ($self) = @_;
1503 1878
1504 # TODO: safety, remove and allow resettable per-player maps 1879 # TODO: safety, remove and allow resettable per-player maps
1505 return 1e99 if $self->isa ("ext::map_per_player");#d#
1506 return 1e99 if $self->{deny_reset}; 1880 return 1e99 if $self->{deny_reset};
1507 1881
1508 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1882 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1509 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;
1510 1884
… …
1515 my ($self) = @_; 1889 my ($self) = @_;
1516 1890
1517 $self->reset_at <= $cf::RUNTIME 1891 $self->reset_at <= $cf::RUNTIME
1518} 1892}
1519 1893
1520sub rename {
1521 my ($self, $new_path) = @_;
1522
1523 normalise $new_path;
1524
1525 $self->unlink_save;
1526
1527 delete $cf::MAP{$self->path};
1528 $self->{path} = $new_path; $self->path ($self->{path});
1529 $cf::MAP{$self->path} = $self;
1530
1531 $self->save;
1532}
1533
1534sub reset { 1894sub reset {
1535 my ($self) = @_; 1895 my ($self) = @_;
1536 1896
1537 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1897 my $lock = cf::lock_acquire "map_data:$self->{path}";
1538 1898
1539 return if $self->players; 1899 return if $self->players;
1540 return if $self->isa ("ext::map_per_player");#d#
1541 1900
1542 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 }
1543 1912
1544 delete $cf::MAP{$self->path}; 1913 delete $cf::MAP{$self->path};
1545 1914
1546 $self->in_memory (cf::MAP_SWAPPED);
1547 $self->clear; 1915 $self->clear;
1548 1916
1549 $_->clear_links_to ($self) for values %cf::MAP; 1917 $_->clear_links_to ($self) for values %cf::MAP;
1550 1918
1551 $self->unlink_save; 1919 $self->unlink_save;
… …
1555my $nuke_counter = "aaaa"; 1923my $nuke_counter = "aaaa";
1556 1924
1557sub nuke { 1925sub nuke {
1558 my ($self) = @_; 1926 my ($self) = @_;
1559 1927
1928 delete $cf::MAP{$self->path};
1929
1930 $self->unlink_save;
1931
1932 bless $self, "cf::map";
1933 delete $self->{deny_reset};
1560 $self->{deny_save} = 1; 1934 $self->{deny_save} = 1;
1561 $self->reset_timeout (1); 1935 $self->reset_timeout (1);
1562 $self->rename ("{nuke}/" . ($nuke_counter++)); 1936 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1937
1938 $cf::MAP{$self->path} = $self;
1939
1563 $self->reset; # polite request, might not happen 1940 $self->reset; # polite request, might not happen
1941}
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 ]
1564} 1977}
1565 1978
1566=item cf::map::unique_maps 1979=item cf::map::unique_maps
1567 1980
1568Returns an arrayref of paths of all shared maps that have 1981Returns an arrayref of paths of all shared maps that have
1569instantiated unique items. May block. 1982instantiated unique items. May block.
1570 1983
1571=cut 1984=cut
1572 1985
1573sub unique_maps() { 1986sub unique_maps() {
1574 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 1987 [
1575 or return; 1988 map {
1576
1577 my @paths;
1578
1579 for (@$files) {
1580 utf8::decode $_; 1989 utf8::decode $_;
1581 next if /\.pst$/;
1582 next unless /^$PATH_SEP/o;
1583
1584 s/\.map$//; 1990 /\.map$/
1585 push @paths, $_; 1991 ? normalise $_
1992 : ()
1993 } @{ aio_readdir $UNIQUEDIR or [] }
1586 } 1994 ]
1587
1588 \@paths
1589} 1995}
1590 1996
1591package cf; 1997package cf;
1592 1998
1593=back 1999=back
… …
1684=cut 2090=cut
1685 2091
1686sub link_map { 2092sub link_map {
1687 unless ($LINK_MAP) { 2093 unless ($LINK_MAP) {
1688 $LINK_MAP = cf::map::find "{link}" 2094 $LINK_MAP = cf::map::find "{link}"
1689 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 2095 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1690 $LINK_MAP->load; 2096 $LINK_MAP->load;
1691 } 2097 }
1692 2098
1693 $LINK_MAP 2099 $LINK_MAP
1694} 2100}
… …
1699 $self->deactivate_recursive; 2105 $self->deactivate_recursive;
1700 2106
1701 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2107 return if UNIVERSAL::isa $self->map, "ext::map_link";
1702 2108
1703 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2109 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1704 if $self->map; 2110 if $self->map && $self->map->{path} ne "{link}";
1705 2111
1706 $self->enter_map ($LINK_MAP || link_map, 20, 20); 2112 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1707} 2113}
1708 2114
1709sub cf::object::player::leave_link { 2115sub cf::object::player::leave_link {
1710 my ($self, $map, $x, $y) = @_; 2116 my ($self, $map, $x, $y) = @_;
2117
2118 return unless $self->contr->active;
1711 2119
1712 my $link_pos = delete $self->{_link_pos}; 2120 my $link_pos = delete $self->{_link_pos};
1713 2121
1714 unless ($map) { 2122 unless ($map) {
1715 # restore original map position 2123 # restore original map position
… …
1733 $map->load; 2141 $map->load;
1734 $map->load_diag; 2142 $map->load_diag;
1735 2143
1736 return unless $self->contr->active; 2144 return unless $self->contr->active;
1737 $self->activate_recursive; 2145 $self->activate_recursive;
2146
2147 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1738 $self->enter_map ($map, $x, $y); 2148 $self->enter_map ($map, $x, $y);
1739} 2149}
1740 2150
1741cf::player->attach (
1742 on_logout => sub {
1743 my ($pl) = @_;
1744
1745 # abort map switching before logout
1746 if ($pl->ob->{_link_pos}) {
1747 cf::sync_job {
1748 $pl->ob->leave_link
1749 };
1750 }
1751 },
1752 on_login => sub {
1753 my ($pl) = @_;
1754
1755 # try to abort aborted map switching on player login :)
1756 # should happen only on crashes
1757 if ($pl->ob->{_link_pos}) {
1758 $pl->ob->enter_link;
1759 (async {
1760 # we need this sleep as the login has a concurrent enter_exit running
1761 # and this sleep increases chances of the player not ending up in scorn
1762 $pl->ob->reply (undef,
1763 "There was an internal problem at your last logout, "
1764 . "the server will try to bring you to your intended destination in a second.",
1765 cf::NDI_RED);
1766 Coro::Timer::sleep 1;
1767 $pl->ob->leave_link;
1768 })->prio (2);
1769 }
1770 },
1771);
1772
1773=item $player_object->goto ($path, $x, $y) 2151=item $player_object->goto ($path, $x, $y[, $check->($map)])
1774 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
1775=cut 2158=cut
2159
2160our $GOTOGEN;
1776 2161
1777sub cf::object::player::goto { 2162sub cf::object::player::goto {
1778 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;
1779 2167
1780 $self->enter_link; 2168 $self->enter_link;
1781 2169
1782 (async { 2170 (async {
2171 my $map = eval {
1783 my $map = cf::map::find $path; 2172 my $map = cf::map::find $path;
2173
2174 if ($map) {
1784 $map = $map->customise_for ($self) if $map; 2175 $map = $map->customise_for ($self);
1785 2176 $map = $check->($map) if $check && $map;
1786# warn "entering ", $map->path, " at ($x, $y)\n" 2177 } else {
1787# if $map;
1788
1789 $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 }
1790 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};
1791 $self->leave_link ($map, $x, $y); 2191 $self->leave_link ($map, $x, $y);
2192 }
1792 })->prio (1); 2193 })->prio (1);
1793} 2194}
1794 2195
1795=item $player_object->enter_exit ($exit_object) 2196=item $player_object->enter_exit ($exit_object)
1796 2197
… …
1798 2199
1799sub parse_random_map_params { 2200sub parse_random_map_params {
1800 my ($spec) = @_; 2201 my ($spec) = @_;
1801 2202
1802 my $rmp = { # defaults 2203 my $rmp = { # defaults
1803 xsize => 10, 2204 xsize => (cf::rndm 15, 40),
1804 ysize => 10, 2205 ysize => (cf::rndm 15, 40),
2206 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2207 #layout => string,
1805 }; 2208 };
1806 2209
1807 for (split /\n/, $spec) { 2210 for (split /\n/, $spec) {
1808 my ($k, $v) = split /\s+/, $_, 2; 2211 my ($k, $v) = split /\s+/, $_, 2;
1809 2212
… …
1813 $rmp 2216 $rmp
1814} 2217}
1815 2218
1816sub prepare_random_map { 2219sub prepare_random_map {
1817 my ($exit) = @_; 2220 my ($exit) = @_;
2221
2222 my $guard = cf::lock_acquire "exit_prepare:$exit";
1818 2223
1819 # all this does is basically replace the /! path by 2224 # all this does is basically replace the /! path by
1820 # a new random map path (?random/...) with a seed 2225 # a new random map path (?random/...) with a seed
1821 # that depends on the exit object 2226 # that depends on the exit object
1822 2227
1823 my $rmp = parse_random_map_params $exit->msg; 2228 my $rmp = parse_random_map_params $exit->msg;
1824 2229
1825 if ($exit->map) { 2230 if ($exit->map) {
1826 $rmp->{region} = $exit->map->region_name; 2231 $rmp->{region} = $exit->region->name;
1827 $rmp->{origin_map} = $exit->map->path; 2232 $rmp->{origin_map} = $exit->map->path;
1828 $rmp->{origin_x} = $exit->x; 2233 $rmp->{origin_x} = $exit->x;
1829 $rmp->{origin_y} = $exit->y; 2234 $rmp->{origin_y} = $exit->y;
1830 } 2235 }
1831 2236
1832 $rmp->{random_seed} ||= $exit->random_seed; 2237 $rmp->{random_seed} ||= $exit->random_seed;
1833 2238
1834 my $data = cf::to_json $rmp; 2239 my $data = cf::to_json $rmp;
1835 my $md5 = Digest::MD5::md5_hex $data; 2240 my $md5 = Digest::MD5::md5_hex $data;
2241 my $meta = "$RANDOMDIR/$md5.meta";
1836 2242
1837 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) {
1838 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;
1839 2247
1840 $exit->slaying ("?random/$md5"); 2248 $exit->slaying ("?random/$md5");
1841 $exit->msg (undef); 2249 $exit->msg (undef);
1842 } 2250 }
1843} 2251}
1844 2252
1845sub cf::object::player::enter_exit { 2253sub cf::object::player::enter_exit {
1846 my ($self, $exit) = @_; 2254 my ($self, $exit) = @_;
1847 2255
1848 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;
1849 2268
1850 $self->enter_link; 2269 $self->enter_link;
1851 2270
1852 (async { 2271 (async {
1853 $self->deactivate_recursive; # just to be sure 2272 $self->deactivate_recursive; # just to be sure
1854 unless (eval { 2273 unless (eval {
1855 prepare_random_map $exit 2274 $self->goto ($slaying, $hp, $sp);
1856 if $exit->slaying eq "/!";
1857
1858 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1859 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1860 2275
1861 1; 2276 1;
1862 }) { 2277 }) {
1863 $self->message ("Something went wrong deep within the crossfire server. " 2278 $self->message ("Something went wrong deep within the crossfire server. "
1864 . "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. "
1865 . "Please report this to the dungeon master!", 2280 . "Please report this to the dungeon master!",
1866 cf::NDI_UNIQUE | cf::NDI_RED); 2281 cf::NDI_UNIQUE | cf::NDI_RED);
1867 2282
1868 warn "ERROR in enter_exit: $@"; 2283 warn "ERROR in enter_exit: $@";
1869 $self->leave_link; 2284 $self->leave_link;
1870 } 2285 }
1871 })->prio (1); 2286 })->prio (1);
… …
1884 2299
1885sub cf::client::send_drawinfo { 2300sub cf::client::send_drawinfo {
1886 my ($self, $text, $flags) = @_; 2301 my ($self, $text, $flags) = @_;
1887 2302
1888 utf8::encode $text; 2303 utf8::encode $text;
1889 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2304 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1890} 2305}
1891 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}
1892 2319
1893=item $success = $client->query ($flags, "text", \&cb) 2320=item $success = $client->query ($flags, "text", \&cb)
1894 2321
1895Queues a query to the client, calling the given callback with 2322Queues a query to the client, calling the given callback with
1896the 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>,
… …
1925 # get handled first 2352 # get handled first
1926 my $queue = delete $ns->{query_queue} 2353 my $queue = delete $ns->{query_queue}
1927 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
1928 2355
1929 (shift @$queue)->[1]->($msg); 2356 (shift @$queue)->[1]->($msg);
2357 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1930 2358
1931 push @{ $ns->{query_queue} }, @$queue; 2359 push @{ $ns->{query_queue} }, @$queue;
1932 2360
1933 if (@{ $ns->{query_queue} } == @$queue) { 2361 if (@{ $ns->{query_queue} } == @$queue) {
1934 if (@$queue) { 2362 if (@$queue) {
… …
1992 2420
1993# here we export the classes and methods available to script code 2421# here we export the classes and methods available to script code
1994 2422
1995=pod 2423=pod
1996 2424
1997The following fucntions and emthods are available within a safe environment: 2425The following functions and methods are available within a safe environment:
1998 2426
1999 cf::object contr pay_amount pay_player map 2427 cf::object contr pay_amount pay_player map
2000 cf::object::player player 2428 cf::object::player player
2001 cf::player peaceful 2429 cf::player peaceful
2002 cf::map trigger 2430 cf::map trigger
… …
2083=back 2511=back
2084 2512
2085=cut 2513=cut
2086 2514
2087############################################################################# 2515#############################################################################
2516# the server's init and main functions
2088 2517
2089=head2 EXTENSION DATABASE SUPPORT 2518sub load_facedata($) {
2519 my ($path) = @_;
2090 2520
2091Crossfire maintains a very simple database for extension use. It can 2521 warn "loading facedata from $path\n";
2092currently store anything that can be serialised using Storable, which
2093excludes objects.
2094 2522
2095The parameter C<$family> should best start with the name of the extension 2523 my $facedata;
2096using it, it should be unique. 2524 0 < aio_load $path, $facedata
2525 or die "$path: $!";
2097 2526
2098=over 4 2527 $facedata = Coro::Storable::thaw $facedata;
2099 2528
2100=item $hashref = cf::db_get $family 2529 $facedata->{version} == 2
2530 or cf::cleanup "$path: version mismatch, cannot proceed.";
2101 2531
2102Return a hashref for use by the extension C<$family>, which can be
2103modified. After modifications, you have to call C<cf::db_dirty> or
2104C<cf::db_sync>.
2105
2106=item $value = cf::db_get $family => $key
2107
2108Returns a single value from the database
2109
2110=item cf::db_put $family => $hashref
2111
2112Stores the given family hashref into the database. Updates are delayed, if
2113you want the data to be synced to disk immediately, use C<cf::db_sync>.
2114
2115=item cf::db_put $family => $key => $value
2116
2117Stores the given C<$value> in the family hash. Updates are delayed, if you
2118want the data to be synced to disk immediately, use C<cf::db_sync>.
2119
2120=item cf::db_dirty
2121
2122Marks the database as dirty, to be updated at a later time.
2123
2124=item cf::db_sync
2125
2126Immediately write the database to disk I<if it is dirty>.
2127
2128=cut
2129
2130our $DB;
2131
2132{
2133 my $path = cf::localdir . "/database.pst";
2134
2135 sub db_load() {
2136 $DB = stat $path ? Storable::retrieve $path : { };
2137 } 2532 {
2533 my $faces = $facedata->{faceinfo};
2138 2534
2139 my $pid; 2535 while (my ($face, $info) = each %$faces) {
2140 2536 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2141 sub db_save() { 2537 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2142 waitpid $pid, 0 if $pid; 2538 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2143 if (0 == ($pid = fork)) { 2539 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2144 $DB->{_meta}{version} = 1; 2540 Coro::cede;
2145 Storable::nstore $DB, "$path~";
2146 rename "$path~", $path;
2147 cf::_exit 0 if defined $pid;
2148 }
2149 }
2150
2151 my $dirty;
2152
2153 sub db_sync() {
2154 db_save if $dirty;
2155 undef $dirty;
2156 }
2157
2158 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2159 db_sync;
2160 });
2161
2162 sub db_dirty() {
2163 $dirty = 1;
2164 $idle->start;
2165 }
2166
2167 sub db_get($;$) {
2168 @_ >= 2
2169 ? $DB->{$_[0]}{$_[1]}
2170 : ($DB->{$_[0]} ||= { })
2171 }
2172
2173 sub db_put($$;$) {
2174 if (@_ >= 3) {
2175 $DB->{$_[0]}{$_[1]} = $_[2];
2176 } else {
2177 $DB->{$_[0]} = $_[1];
2178 }
2179 db_dirty;
2180 }
2181
2182 cf::global->attach (
2183 prio => 10000,
2184 on_cleanup => sub {
2185 db_sync;
2186 }, 2541 }
2187 );
2188}
2189 2542
2190############################################################################# 2543 while (my ($face, $info) = each %$faces) {
2191# 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}
2192 2605
2193sub cfg_load { 2606sub cfg_load {
2194 open my $fh, "<:utf8", cf::confdir . "/config" 2607 open my $fh, "<:utf8", "$CONFDIR/config"
2195 or return; 2608 or return;
2196 2609
2197 local $/; 2610 local $/;
2198 *CFG = YAML::Syck::Load <$fh>; 2611 *CFG = YAML::Syck::Load <$fh>;
2199 2612
… …
2213 2626
2214sub main { 2627sub main {
2215 # we must not ever block the main coroutine 2628 # we must not ever block the main coroutine
2216 local $Coro::idle = sub { 2629 local $Coro::idle = sub {
2217 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2630 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2631 (async {
2218 async { Event::one_event }; 2632 Event::one_event;
2633 })->prio (Coro::PRIO_MAX);
2219 }; 2634 };
2220 2635
2221 cfg_load; 2636 cfg_load;
2222 db_load; 2637 db_init;
2223 load_extensions; 2638 load_extensions;
2639
2640 $TICK_WATCHER->start;
2224 Event::loop; 2641 Event::loop;
2225} 2642}
2226 2643
2227############################################################################# 2644#############################################################################
2228# initialisation and cleanup 2645# initialisation and cleanup
2229 2646
2230# install some emergency cleanup handlers 2647# install some emergency cleanup handlers
2231BEGIN { 2648BEGIN {
2232 for my $signal (qw(INT HUP TERM)) { 2649 for my $signal (qw(INT HUP TERM)) {
2233 Event->signal ( 2650 Event->signal (
2651 reentrant => 0,
2234 data => WF_AUTOCANCEL, 2652 data => WF_AUTOCANCEL,
2235 signal => $signal, 2653 signal => $signal,
2654 prio => 0,
2236 cb => sub { 2655 cb => sub {
2237 cf::cleanup "SIG$signal"; 2656 cf::cleanup "SIG$signal";
2238 }, 2657 },
2239 ); 2658 );
2240 } 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
2241} 2698}
2242 2699
2243sub emergency_save() { 2700sub emergency_save() {
2244 my $freeze_guard = cf::freeze_mainloop; 2701 my $freeze_guard = cf::freeze_mainloop;
2245 2702
… …
2262 my $map = $cf::MAP{$path} or next; 2719 my $map = $cf::MAP{$path} or next;
2263 $map->valid or next; 2720 $map->valid or next;
2264 $map->save; 2721 $map->save;
2265 } 2722 }
2266 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";
2267 }; 2728 };
2268 2729
2269 warn "leave emergency perl save\n"; 2730 warn "leave emergency perl save\n";
2270} 2731}
2271 2732
2733sub post_cleanup {
2734 my ($make_core) = @_;
2735
2736 warn Carp::longmess "post_cleanup backtrace"
2737 if $make_core;
2738}
2739
2272sub reload() { 2740sub do_reload_perl() {
2273 # can/must only be called in main 2741 # can/must only be called in main
2274 if ($Coro::current != $Coro::main) { 2742 if ($Coro::current != $Coro::main) {
2275 warn "can only reload from main coroutine\n"; 2743 warn "can only reload from main coroutine";
2276 return; 2744 return;
2277 } 2745 }
2278 2746
2279 warn "reloading..."; 2747 warn "reloading...";
2280 2748
2281 warn "freezing server"; 2749 warn "entering sync_job";
2282 my $guard = freeze_mainloop; 2750
2751 cf::sync_job {
2752 cf::write_runtime; # external watchdog should not bark
2283 cf::emergency_save; 2753 cf::emergency_save;
2754 cf::write_runtime; # external watchdog should not bark
2284 2755
2285 warn "sync database to disk"; 2756 warn "syncing database to disk";
2286 cf::db_sync; 2757 BDB::db_env_txn_checkpoint $DB_ENV;
2287 IO::AIO::flush;
2288 2758
2289 eval {
2290 # 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
2291 2760
2292 warn "cancel all watchers"; 2761 warn "cancelling all WF_AUTOCANCEL watchers";
2293 for (Event::all_watchers) { 2762 for (Event::all_watchers) {
2294 $_->cancel if $_->data & WF_AUTOCANCEL; 2763 $_->cancel if $_->data & WF_AUTOCANCEL;
2295 } 2764 }
2296 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
2297 warn "cancel all extension coros"; 2777 warn "cancelling all extension coros";
2298 $_->cancel for values %EXT_CORO; 2778 $_->cancel for values %EXT_CORO;
2299 %EXT_CORO = (); 2779 %EXT_CORO = ();
2300 2780
2301 warn "remove commands"; 2781 warn "removing commands";
2302 %COMMAND = (); 2782 %COMMAND = ();
2303 2783
2304 warn "remove ext commands"; 2784 warn "removing ext commands";
2305 %EXTCMD = (); 2785 %EXTCMD = ();
2306 2786
2307 warn "unload/nuke all extensions"; 2787 warn "unloading/nuking all extensions";
2308 for my $pkg (@EXTS) { 2788 for my $pkg (@EXTS) {
2309 warn "... unloading $pkg"; 2789 warn "... unloading $pkg";
2310 2790
2311 if (my $cb = $pkg->can ("unload")) { 2791 if (my $cb = $pkg->can ("unload")) {
2312 eval { 2792 eval {
… …
2317 2797
2318 warn "... nuking $pkg"; 2798 warn "... nuking $pkg";
2319 Symbol::delete_package $pkg; 2799 Symbol::delete_package $pkg;
2320 } 2800 }
2321 2801
2322 warn "unload all perl modules loaded from $LIBDIR"; 2802 warn "unloading all perl modules loaded from $LIBDIR";
2323 while (my ($k, $v) = each %INC) { 2803 while (my ($k, $v) = each %INC) {
2324 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2804 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2325 2805
2326 warn "removing <$k>"; 2806 warn "... unloading $k";
2327 delete $INC{$k}; 2807 delete $INC{$k};
2328 2808
2329 $k =~ s/\.pm$//; 2809 $k =~ s/\.pm$//;
2330 $k =~ s/\//::/g; 2810 $k =~ s/\//::/g;
2331 2811
… …
2334 } 2814 }
2335 2815
2336 Symbol::delete_package $k; 2816 Symbol::delete_package $k;
2337 } 2817 }
2338 2818
2339 warn "get rid of safe::, as good as possible"; 2819 warn "getting rid of safe::, as good as possible";
2340 Symbol::delete_package "safe::$_" 2820 Symbol::delete_package "safe::$_"
2341 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);
2342 2822
2343 warn "unload cf.pm \"a bit\""; 2823 warn "unloading cf.pm \"a bit\"";
2344 delete $INC{"cf.pm"}; 2824 delete $INC{"cf.pm"};
2825 delete $INC{"cf/pod.pm"};
2345 2826
2346 # don't, removes xs symbols, too, 2827 # don't, removes xs symbols, too,
2347 # and global variables created in xs 2828 # and global variables created in xs
2348 #Symbol::delete_package __PACKAGE__; 2829 #Symbol::delete_package __PACKAGE__;
2349 2830
2831 warn "unload completed, starting to reload now";
2832
2350 warn "reloading cf.pm"; 2833 warn "reloading cf.pm";
2351 require cf; 2834 require cf;
2352 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2835 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2353 2836
2354 warn "load config and database again"; 2837 warn "loading config and database again";
2355 cf::cfg_load; 2838 cf::cfg_load;
2356 cf::db_load;
2357 2839
2358 warn "load extensions"; 2840 warn "loading extensions";
2359 cf::load_extensions; 2841 cf::load_extensions;
2360 2842
2361 warn "reattach attachments to objects/players"; 2843 warn "reattaching attachments to objects/players";
2362 _global_reattach; 2844 _global_reattach; # objects, sockets
2363 warn "reattach attachments to maps"; 2845 warn "reattaching attachments to maps";
2364 reattach $_ for values %MAP; 2846 reattach $_ for values %MAP;
2365 }; 2847 warn "reattaching attachments to players";
2848 reattach $_ for values %PLAYER;
2366 2849
2367 if ($@) { 2850 warn "leaving sync_job";
2851
2852 1
2853 } or do {
2368 warn $@; 2854 warn $@;
2369 warn "error while reloading, exiting."; 2855 warn "error while reloading, exiting.";
2370 exit 1; 2856 exit 1;
2371 } 2857 };
2372 2858
2373 warn "reloaded"; 2859 warn "reloaded";
2374}; 2860};
2375 2861
2862our $RELOAD_WATCHER; # used only during reload
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
2376register_command "reload" => sub { 2879register_command "reload" => sub {
2377 my ($who, $arg) = @_; 2880 my ($who, $arg) = @_;
2378 2881
2379 if ($who->flag (FLAG_WIZ)) { 2882 if ($who->flag (FLAG_WIZ)) {
2380 $who->message ("start of reload.");
2381 reload;
2382 $who->message ("end of reload."); 2883 $who->message ("reloading server.");
2884 async { reload_perl };
2383 } 2885 }
2384}; 2886};
2385 2887
2386unshift @INC, $LIBDIR; 2888unshift @INC, $LIBDIR;
2387 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;
2388$TICK_WATCHER = Event->timer ( 2915$TICK_WATCHER = Event->timer (
2389 reentrant => 0, 2916 reentrant => 0,
2917 parked => 1,
2390 prio => 0, 2918 prio => 0,
2391 at => $NEXT_TICK || $TICK, 2919 at => $NEXT_TICK || $TICK,
2392 data => WF_AUTOCANCEL, 2920 data => WF_AUTOCANCEL,
2393 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
2394 $NOW = Event::time; 2928 $NOW = $tick_start = Event::time;
2395 2929
2396 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
2397 $RUNTIME += $TICK; 2955 $RUNTIME += $TICK;
2398 $NEXT_TICK += $TICK; 2956 $NEXT_TICK += $TICK;
2399 2957
2400 $WAIT_FOR_TICK->broadcast; 2958 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2401 $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;
2402 2977
2403 # 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
2404 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2979 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2405 2980
2406 $TICK_WATCHER->at ($NEXT_TICK); 2981 $TICK_WATCHER->at ($NEXT_TICK);
2407 $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
2408 }, 2990 },
2409); 2991);
2410 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;
2411IO::AIO::max_poll_time $TICK * 0.2; 3047 IO::AIO::max_poll_time $TICK * 0.1;
2412
2413$AIO_POLL_WATCHER = Event->io ( 3048 $AIO_POLL_WATCHER = Event->io (
2414 fd => IO::AIO::poll_fileno, 3049 reentrant => 0,
2415 poll => 'r',
2416 prio => 5,
2417 data => WF_AUTOCANCEL,
2418 cb => \&IO::AIO::poll_cb,
2419);
2420
2421$WRITE_RUNTIME_WATCHER = Event->timer (
2422 data => WF_AUTOCANCEL, 3050 data => WF_AUTOCANCEL,
2423 after => 0, 3051 fd => IO::AIO::poll_fileno,
2424 interval => 10, 3052 poll => 'r',
2425 cb => sub { 3053 prio => 6,
2426 (Coro::unblock_sub { 3054 cb => \&IO::AIO::poll_cb,
2427 write_runtime 3055 );
2428 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;
2429 })->(); 3089 };
3090 } else {
3091 LOG llevInfo, "[ABT] $msg\n";
3092 LOG llevInfo, "[ABT] [suppressed]\n";
2430 }, 3093 }
2431); 3094}
3095
3096# load additional modules
3097use cf::pod;
2432 3098
2433END { cf::emergency_save } 3099END { cf::emergency_save }
2434 3100
24351 31011
2436 3102

Diff Legend

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