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.231 by root, Wed Apr 4 00:02:06 2007 UTC vs.
Revision 1.283 by root, Sun Jun 24 04:09:29 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;
9use Event; 10use Event;
10use Opcode; 11use Opcode;
11use Safe; 12use Safe;
12use Safe::Hole; 13use Safe::Hole;
13 14
14use Coro 3.52 (); 15use Coro 3.61 ();
15use Coro::State; 16use Coro::State;
17use Coro::Handle;
16use Coro::Event; 18use Coro::Event;
17use Coro::Timer; 19use Coro::Timer;
18use Coro::Signal; 20use Coro::Signal;
19use Coro::Semaphore; 21use Coro::Semaphore;
20use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
21 24
22use BDB (); 25use BDB ();
23use Data::Dumper; 26use Data::Dumper;
24use Digest::MD5; 27use Digest::MD5;
25use Fcntl; 28use Fcntl;
… …
28use Time::HiRes; 31use Time::HiRes;
29use Compress::LZF; 32use Compress::LZF;
30 33
31# configure various modules to our taste 34# configure various modules to our taste
32# 35#
36$Storable::canonical = 1; # reduce rsync transfers
33Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
34Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
35 39
36$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
37 41
… …
50our %EXT_CORO = (); # coroutines bound to extensions 54our %EXT_CORO = (); # coroutines bound to extensions
51our %EXT_MAP = (); # pluggable maps 55our %EXT_MAP = (); # pluggable maps
52 56
53our $RELOAD; # number of reloads so far 57our $RELOAD; # number of reloads so far
54our @EVENT; 58our @EVENT;
55our $LIBDIR = datadir . "/ext";
56 59
57our $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(!)
58our $TICK_WATCHER; 73our $TICK_WATCHER;
59our $AIO_POLL_WATCHER; 74our $AIO_POLL_WATCHER;
60our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
61our $NEXT_TICK; 76our $NEXT_TICK;
62our $NOW; 77our $NOW;
… …
71our $RUNTIME; 86our $RUNTIME;
72 87
73our %PLAYER; # all users 88our %PLAYER; # all users
74our %MAP; # all maps 89our %MAP; # all maps
75our $LINK_MAP; # the special {link} map, which is always available 90our $LINK_MAP; # the special {link} map, which is always available
76our $RANDOM_MAPS = cf::localdir . "/random";
77our $BDB_ENV_DIR = cf::localdir . "/db";
78
79our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
80our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
81 91
82# 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 ∕
83our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
84 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
85binmode STDOUT; 99binmode STDOUT;
86binmode STDERR; 100binmode STDERR;
87 101
88# read virtual server time, if available 102# read virtual server time, if available
89unless ($RUNTIME || !-e cf::localdir . "/runtime") { 103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
90 open my $fh, "<", cf::localdir . "/runtime" 104 open my $fh, "<", "$LOCALDIR/runtime"
91 or die "unable to read runtime file: $!"; 105 or die "unable to read runtime file: $!";
92 $RUNTIME = <$fh> + 0.; 106 $RUNTIME = <$fh> + 0.;
93} 107}
94 108
95mkdir cf::localdir; 109mkdir $_
96mkdir cf::localdir . "/" . cf::playerdir; 110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
97mkdir cf::localdir . "/" . cf::tmpdir;
98mkdir cf::localdir . "/" . cf::uniquedir;
99mkdir $RANDOM_MAPS;
100mkdir $BDB_ENV_DIR;
101 111
102our $EMERGENCY_POSITION; 112our $EMERGENCY_POSITION;
103 113
104sub cf::map::normalise; 114sub cf::map::normalise;
105 115
… …
116=item $cf::RUNTIME 126=item $cf::RUNTIME
117 127
118The 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
119every server tick. 129every server tick.
120 130
121=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
122 134
123The perl library directory, where extensions and cf-specific modules can 135Various directories - "/etc", read-only install directory, perl-library
124be 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.
125 139
126=item $cf::NOW 140=item $cf::NOW
127 141
128The time of the last (current) server tick. 142The time of the last (current) server tick.
129 143
130=item $cf::TICK 144=item $cf::TICK
131 145
132The 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.
133 157
134=item %cf::CFG 158=item %cf::CFG
135 159
136Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
137from wherever your confdir points to. 161from wherever your confdir points to.
138 162
139=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 163=item cf::wait_for_tick, cf::wait_for_tick_begin
140 164
141These 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
142or 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
143processing 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.
144window of cpu time available, or simply to synchronise to the server tick.
145 168
146=back 169=back
147 170
148=cut 171=cut
149 172
150BEGIN { 173BEGIN {
151 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
152 my $msg = join "", @_; 175 my $msg = join "", @_;
153 utf8::encode $msg;
154 176
155 $msg .= "\n" 177 $msg .= "\n"
156 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
157 179
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
158 LOG llevError, $msg; 183 LOG llevError, $msg;
159 }; 184 };
160} 185}
161 186
162@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
163@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
164@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
165@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
166@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';
167@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)
168 194
169# 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
170# within the Safe compartment. 196# within the Safe compartment.
171for my $pkg (qw( 197for my $pkg (qw(
172 cf::global cf::attachable 198 cf::global cf::attachable
… …
180} 206}
181 207
182$Event::DIED = sub { 208$Event::DIED = sub {
183 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
184}; 210};
211
212#############################################################################
185 213
186=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
187 215
188=over 4 216=over 4
189 217
… …
232returned. 260returned.
233 261
234Lock 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
235uses map_find and cf::map::load uses map_load). 263uses map_find and cf::map::load uses map_load).
236 264
265=item $locked = cf::lock_active $string
266
267Return true if the lock is currently active, i.e. somebody has locked it.
268
237=cut 269=cut
238 270
239our %LOCK; 271our %LOCK;
240 272
241sub lock_wait($) { 273sub lock_wait($) {
… …
258 290
259 Coro::guard { 291 Coro::guard {
260 # wake up all waiters, to be on the safe side 292 # wake up all waiters, to be on the safe side
261 $_->ready for @{ delete $LOCK{$key} }; 293 $_->ready for @{ delete $LOCK{$key} };
262 } 294 }
295}
296
297sub lock_active($) {
298 my ($key) = @_;
299
300 ! ! $LOCK{$key}
263} 301}
264 302
265sub freeze_mainloop { 303sub freeze_mainloop {
266 return unless $TICK_WATCHER->is_active; 304 return unless $TICK_WATCHER->is_active;
267 305
… …
282 320
283BEGIN { *async = \&Coro::async_pool } 321BEGIN { *async = \&Coro::async_pool }
284 322
285=item cf::sync_job { BLOCK } 323=item cf::sync_job { BLOCK }
286 324
287The design of crossfire+ requires that the main coro ($Coro::main) is 325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
288always able to handle events or runnable, as crossfire+ is only partly 326is always able to handle events or runnable, as Crossfire TRT is only
289reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 327partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
328acceptable.
290 329
291If 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
292the given BLOCK in another coroutine while waiting for the result. The 331the given BLOCK in another coroutine while waiting for the result. The
293server 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
294fast or be very important. 333fast or be very important.
… …
297 336
298sub sync_job(&) { 337sub sync_job(&) {
299 my ($job) = @_; 338 my ($job) = @_;
300 339
301 if ($Coro::current == $Coro::main) { 340 if ($Coro::current == $Coro::main) {
341 my $time = Event::time;
342
302 # this is the main coro, too bad, we have to block 343 # this is the main coro, too bad, we have to block
303 # till the operation succeeds, freezing the server :/ 344 # till the operation succeeds, freezing the server :/
304 345
305 # TODO: use suspend/resume instead 346 # TODO: use suspend/resume instead
306 # (but this is cancel-safe) 347 # (but this is cancel-safe)
… …
317 358
318 while ($busy) { 359 while ($busy) {
319 Coro::cede or Event::one_event; 360 Coro::cede or Event::one_event;
320 } 361 }
321 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
322 wantarray ? @res : $res[0] 370 wantarray ? @res : $res[0]
323 } else { 371 } else {
324 # we are in another coroutine, how wonderful, everything just works 372 # we are in another coroutine, how wonderful, everything just works
325 373
326 $job->() 374 $job->()
… …
345 $EXT_CORO{$coro+0} = $coro; 393 $EXT_CORO{$coro+0} = $coro;
346 394
347 $coro 395 $coro
348} 396}
349 397
350sub write_runtime { 398=item fork_call { }, $args
351 my $guard = cf::lock_acquire "write_runtime";
352 399
353 my $runtime = cf::localdir . "/runtime"; 400Executes the given code block with the given arguments in a seperate
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.
354 404
355 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 405=cut
356 or return;
357 406
358 my $value = $cf::RUNTIME + 90 + 10; 407sub fork_call(&@) {
359 # 10 is the runtime save interval, for a monotonic clock 408 my ($cb, @args) = @_;
360 # 60 allows for the watchdog to kill the server.
361 409
362 (aio_write $fh, 0, (length $value), $value, 0) <= 0 410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
363 and return; 411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
364 414
365 # always fsync - this file is important 415 if (my $pid = fork) {
366 aio_fsync $fh
367 and return;
368
369 close $fh 416 close $fh2;
370 or return;
371 417
372 aio_rename "$runtime~", $runtime 418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
373 and return; 419 $res = Coro::Storable::thaw $res;
374 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;
375 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"
376} 556}
377 557
378=item cf::datalog type => key => value, ... 558=item cf::datalog type => key => value, ...
379 559
380Log a datalog packet of the given type with the given key-value pairs. 560Log a datalog packet of the given type with the given key-value pairs.
… …
398attach callbacks/event handlers (a collection of which is called an "attachment") 578attach callbacks/event handlers (a collection of which is called an "attachment")
399to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
400 580
401In 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>
402C<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
403crossfire+). 583Crossfire TRT).
404 584
405=over 4 585=over 4
406 586
407=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
408 588
… …
571 $registry = $CB_TYPE[$object_type] ||= []; 751 $registry = $CB_TYPE[$object_type] ||= [];
572 752
573 } elsif ($type eq "subtype") { 753 } elsif ($type eq "subtype") {
574 defined $object_type or Carp::croak "subtype specified without type"; 754 defined $object_type or Carp::croak "subtype specified without type";
575 my $object_subtype = shift @arg; 755 my $object_subtype = shift @arg;
576 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 756 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
577 757
578 } elsif ($type eq "package") { 758 } elsif ($type eq "package") {
579 my $pkg = shift @arg; 759 my $pkg = shift @arg;
580 760
581 while (my ($name, $id) = each %cb_id) { 761 while (my ($name, $id) = each %cb_id) {
… …
610 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
611 } 791 }
612 792
613 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
614 } else { 794 } else {
615 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
616 } 796 }
617 797
618 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
619} 799}
620 800
… …
622 if (ref $_[0]) { 802 if (ref $_[0]) {
623 _object_attach @_; 803 _object_attach @_;
624 } else { 804 } else {
625 _attach shift->_attach_registry, @_; 805 _attach shift->_attach_registry, @_;
626 } 806 }
807 _recalc_want;
627}; 808};
628 809
629# all those should be optimised 810# all those should be optimised
630sub cf::attachable::detach { 811sub cf::attachable::detach {
631 my ($obj, $name) = @_; 812 my ($obj, $name) = @_;
… …
634 delete $obj->{_attachment}{$name}; 815 delete $obj->{_attachment}{$name};
635 reattach ($obj); 816 reattach ($obj);
636 } else { 817 } else {
637 Carp::croak "cannot, currently, detach class attachments"; 818 Carp::croak "cannot, currently, detach class attachments";
638 } 819 }
820 _recalc_want;
639}; 821};
640 822
641sub cf::attachable::attached { 823sub cf::attachable::attached {
642 my ($obj, $name) = @_; 824 my ($obj, $name) = @_;
643 825
… …
816 or return; 998 or return;
817 $av = eval { (Storable::thaw $av)->{objs} }; 999 $av = eval { (Storable::thaw $av)->{objs} };
818 } 1000 }
819 1001
820 warn sprintf "loading %s (%d)\n", 1002 warn sprintf "loading %s (%d)\n",
821 $filename, length $data, scalar @{$av || []};#d# 1003 $filename, length $data, scalar @{$av || []};
822 return ($data, $av); 1004 return ($data, $av);
823} 1005}
1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
824 1012
825############################################################################# 1013#############################################################################
826# command handling &c 1014# command handling &c
827 1015
828=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
… …
841 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
842} 1030}
843 1031
844=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
845 1033
846Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
847 1035
848If 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
849called. 1037called.
850 1038
851=cut 1039=cut
… …
886 1074
887 cf::override; 1075 cf::override;
888 }, 1076 },
889); 1077);
890 1078
891sub load_extension {
892 my ($path) = @_;
893
894 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
895 my $base = $1;
896 my $pkg = $1;
897 $pkg =~ s/[^[:word:]]/_/g;
898 $pkg = "ext::$pkg";
899
900 warn "... loading '$path' into '$pkg'\n";
901
902 open my $fh, "<:utf8", $path
903 or die "$path: $!";
904
905 my $source =
906 "package $pkg; use strict; use utf8;\n"
907 . "#line 1 \"$path\"\n{\n"
908 . (do { local $/; <$fh> })
909 . "\n};\n1";
910
911 unless (eval $source) {
912 my $msg = $@ ? "$path: $@\n"
913 : "extension disabled.\n";
914 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
915 warn $@;
916 warn "mandatory extension failed to load, exiting.\n";
917 exit 1;
918 }
919 die $@;
920 }
921
922 push @EXTS, $pkg;
923}
924
925sub load_extensions { 1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
926 for my $ext (<$LIBDIR/*.ext>) { 1083 for my $path (<$LIBDIR/*.ext>) {
927 next unless -r $ext; 1084 next unless -r $path;
928 eval { 1085
929 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;
930 1 1143 }
931 } or warn "$ext not loaded: $@"; 1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
932 } 1149 };
933} 1150}
934 1151
935############################################################################# 1152#############################################################################
936 1153
1154=back
1155
937=head2 CORE EXTENSIONS 1156=head2 CORE EXTENSIONS
938 1157
939Functions and methods that extend core crossfire objects. 1158Functions and methods that extend core crossfire objects.
940 1159
941=cut 1160=cut
… …
953Returns the given player object, loading it if necessary (might block). 1172Returns the given player object, loading it if necessary (might block).
954 1173
955=cut 1174=cut
956 1175
957sub playerdir($) { 1176sub playerdir($) {
958 cf::localdir 1177 "$PLAYERDIR/"
959 . "/"
960 . cf::playerdir
961 . "/"
962 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1178 . (ref $_[0] ? $_[0]->ob->name : $_[0])
963} 1179}
964 1180
965sub path($) { 1181sub path($) {
966 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1182 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
967 1183
968 (playerdir $login) . "/$login.pl" 1184 (playerdir $login) . "/playerdata"
969} 1185}
970 1186
971sub find_active($) { 1187sub find_active($) {
972 $cf::PLAYER{$_[0]} 1188 $cf::PLAYER{$_[0]}
973 and $cf::PLAYER{$_[0]}->active 1189 and $cf::PLAYER{$_[0]}->active
… …
986 my $login = $_[0]; 1202 my $login = $_[0];
987 1203
988 my $guard = cf::lock_acquire "user_find:$login"; 1204 my $guard = cf::lock_acquire "user_find:$login";
989 1205
990 $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
991 my $pl = load_pl path $login 1214 my $pl = load_pl path $login
992 or return; 1215 or return;
993 $cf::PLAYER{$login} = $pl 1216 $cf::PLAYER{$login} = $pl
994 } 1217 }
995 } 1218 }
… …
1079while and may block, so not sync_job-capable, ever. 1302while and may block, so not sync_job-capable, ever.
1080 1303
1081=cut 1304=cut
1082 1305
1083sub list_logins { 1306sub list_logins {
1084 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1307 my $dirs = aio_readdir $PLAYERDIR
1085 or return []; 1308 or return [];
1086 1309
1087 my @logins; 1310 my @logins;
1088 1311
1089 for my $login (@$dirs) { 1312 for my $login (@$dirs) {
… …
1124 } 1347 }
1125 1348
1126 \@paths 1349 \@paths
1127} 1350}
1128 1351
1352=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1353
1354Expand crossfire pod fragments into protocol xml.
1355
1356=cut
1357
1358sub expand_cfpod {
1359 ((my $self), (local $_)) = @_;
1360
1361 # escape & and <
1362 s/&/&amp;/g;
1363 s/(?<![BIUGH])</&lt;/g;
1364
1365 # this is buggy, it needs to properly take care of nested <'s
1366
1367 1 while
1368 # replace B<>, I<>, U<> etc.
1369 s/B<([^\>]*)>/<b>$1<\/b>/
1370 || s/I<([^\>]*)>/<i>$1<\/i>/
1371 || s/U<([^\>]*)>/<u>$1<\/u>/
1372 # replace G<male|female> tags
1373 || s{G<([^>|]*)\|([^>]*)>}{
1374 $self->gender ? $2 : $1
1375 }ge
1376 # replace H<hint text>
1377 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
1378
1379 # create single paragraphs (very hackish)
1380 s/(?<=\S)\n(?=\w)/ /g;
1381
1382 $_
1383}
1384
1129=item $player->ext_reply ($msgid, %msg) 1385=item $player->ext_reply ($msgid, %msg)
1130 1386
1131Sends an ext reply to the player. 1387Sends an ext reply to the player.
1132 1388
1133=cut 1389=cut
… …
1147=cut 1403=cut
1148 1404
1149sub ext_event($$%) { 1405sub ext_event($$%) {
1150 my ($self, $type, %msg) = @_; 1406 my ($self, $type, %msg) = @_;
1151 1407
1152 delete $msg{msgid}; 1408 $self->ns->ext_event ($type, %msg);
1153 $msg{msgtype} = "event";
1154 $msg{eventtype} = $type;
1155
1156 $self->send ("ext " . cf::to_json \%msg);
1157} 1409}
1158 1410
1159package cf; 1411=head3 cf::region
1412
1413=over 4
1414
1415=cut
1416
1417package cf::region;
1418
1419=item cf::region::find_by_path $path
1420
1421Tries to decuce the likely region for a map knowing only its path.
1422
1423=cut
1424
1425sub find_by_path($) {
1426 my ($path) = @_;
1427
1428 my ($match, $specificity);
1429
1430 for my $region (list) {
1431 if ($region->match && $path =~ $region->match) {
1432 ($match, $specificity) = ($region, $region->specificity)
1433 if $region->specificity > $specificity;
1434 }
1435 }
1436
1437 $match
1438}
1160 1439
1161=back 1440=back
1162
1163 1441
1164=head3 cf::map 1442=head3 cf::map
1165 1443
1166=over 4 1444=over 4
1167 1445
… …
1222 my ($self, $merge) = @_; 1500 my ($self, $merge) = @_;
1223 1501
1224 # we have to keep some variables in memory intact 1502 # we have to keep some variables in memory intact
1225 local $self->{path}; 1503 local $self->{path};
1226 local $self->{load_path}; 1504 local $self->{load_path};
1227 local $self->{deny_save};
1228 local $self->{deny_reset};
1229 1505
1230 $self->SUPER::thawer_merge ($merge); 1506 $self->SUPER::thawer_merge ($merge);
1231} 1507}
1232 1508
1233sub normalise { 1509sub normalise {
… …
1305 1581
1306# the original (read-only) location 1582# the original (read-only) location
1307sub load_path { 1583sub load_path {
1308 my ($self) = @_; 1584 my ($self) = @_;
1309 1585
1310 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1586 "$MAPDIR/$self->{path}.map"
1311} 1587}
1312 1588
1313# the temporary/swap location 1589# the temporary/swap location
1314sub save_path { 1590sub save_path {
1315 my ($self) = @_; 1591 my ($self) = @_;
1316 1592
1317 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1593 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1318 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1594 "$TMPDIR/$path.map"
1319} 1595}
1320 1596
1321# the unique path, undef == no special unique path 1597# the unique path, undef == no special unique path
1322sub uniq_path { 1598sub uniq_path {
1323 my ($self) = @_; 1599 my ($self) = @_;
1324 1600
1325 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1601 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1326 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1602 "$UNIQUEDIR/$path"
1327} 1603}
1328 1604
1329# and all this just because we cannot iterate over 1605# and all this just because we cannot iterate over
1330# all maps in C++... 1606# all maps in C++...
1331sub change_all_map_light { 1607sub change_all_map_light {
1332 my ($change) = @_; 1608 my ($change) = @_;
1333 1609
1334 $_->change_map_light ($change) 1610 $_->change_map_light ($change)
1335 for grep $_->outdoor, values %cf::MAP; 1611 for grep $_->outdoor, values %cf::MAP;
1612}
1613
1614sub decay_objects {
1615 my ($self) = @_;
1616
1617 return if $self->{deny_reset};
1618
1619 $self->do_decay_objects;
1336} 1620}
1337 1621
1338sub unlink_save { 1622sub unlink_save {
1339 my ($self) = @_; 1623 my ($self) = @_;
1340 1624
… …
1398 $self->load_header_orig 1682 $self->load_header_orig
1399 or return; 1683 or return;
1400 $self->prepare_orig; 1684 $self->prepare_orig;
1401 } 1685 }
1402 1686
1687 $self->{deny_reset} = 1
1688 if $self->no_reset;
1689
1690 $self->default_region (cf::region::find_by_path $self->{path})
1691 unless $self->default_region;
1692
1403 1 1693 1
1404} 1694}
1405 1695
1406sub find; 1696sub find;
1407sub find { 1697sub find {
… …
1419 $map->{last_save} = $cf::RUNTIME; 1709 $map->{last_save} = $cf::RUNTIME;
1420 1710
1421 $map->load_header 1711 $map->load_header
1422 or return; 1712 or return;
1423 1713
1424 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1714 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1425 # doing this can freeze the server in a sync job, obviously 1715 # doing this can freeze the server in a sync job, obviously
1426 #$cf::WAIT_FOR_TICK->wait; 1716 #$cf::WAIT_FOR_TICK->wait;
1427 $map->reset; 1717 $map->reset;
1428 undef $guard; 1718 undef $guard;
1429 return find $path; 1719 return find $path;
… …
1440 my ($self) = @_; 1730 my ($self) = @_;
1441 1731
1442 local $self->{deny_reset} = 1; # loading can take a long time 1732 local $self->{deny_reset} = 1; # loading can take a long time
1443 1733
1444 my $path = $self->{path}; 1734 my $path = $self->{path};
1735
1736 {
1445 my $guard = cf::lock_acquire "map_load:$path"; 1737 my $guard = cf::lock_acquire "map_load:$path";
1446 1738
1447 return if $self->in_memory != cf::MAP_SWAPPED; 1739 return if $self->in_memory != cf::MAP_SWAPPED;
1448 1740
1449 $self->in_memory (cf::MAP_LOADING); 1741 $self->in_memory (cf::MAP_LOADING);
1450 1742
1451 $self->alloc; 1743 $self->alloc;
1452 1744
1453 $self->pre_load; 1745 $self->pre_load;
1454
1455 $self->_load_objects ($self->{load_path}, 1)
1456 or return;
1457
1458 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1459 if delete $self->{load_original};
1460
1461 if (my $uniq = $self->uniq_path) {
1462 utf8::encode $uniq;
1463 if (aio_open $uniq, O_RDONLY, 0) {
1464 $self->clear_unique_items;
1465 $self->_load_objects ($uniq, 0);
1466 }
1467 }
1468
1469 Coro::cede;
1470
1471 # now do the right thing for maps
1472 $self->link_multipart_objects;
1473
1474 unless ($self->{deny_activate}) {
1475 $self->decay_objects;
1476 $self->fix_auto_apply;
1477 $self->update_buttons;
1478 Coro::cede; 1746 Coro::cede;
1479 $self->set_darkness_map; 1747
1748 $self->_load_objects ($self->{load_path}, 1)
1749 or return;
1750
1751 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1752 if delete $self->{load_original};
1753
1754 if (my $uniq = $self->uniq_path) {
1755 utf8::encode $uniq;
1756 if (aio_open $uniq, O_RDONLY, 0) {
1757 $self->clear_unique_items;
1758 $self->_load_objects ($uniq, 0);
1759 }
1760 }
1761
1762 Coro::cede;
1763 # now do the right thing for maps
1764 $self->link_multipart_objects;
1480 $self->difficulty ($self->estimate_difficulty) 1765 $self->difficulty ($self->estimate_difficulty)
1481 unless $self->difficulty; 1766 unless $self->difficulty;
1482 Coro::cede; 1767 Coro::cede;
1768
1769 unless ($self->{deny_activate}) {
1770 $self->decay_objects;
1771 $self->fix_auto_apply;
1772 $self->update_buttons;
1773 Coro::cede;
1774 $self->set_darkness_map;
1775 Coro::cede;
1483 $self->activate; 1776 $self->activate;
1777 }
1778
1779 $self->in_memory (cf::MAP_IN_MEMORY);
1484 } 1780 }
1485 1781
1486 $self->post_load; 1782 $self->post_load;
1487
1488 $self->in_memory (cf::MAP_IN_MEMORY);
1489} 1783}
1490 1784
1491sub customise_for { 1785sub customise_for {
1492 my ($self, $ob) = @_; 1786 my ($self, $ob) = @_;
1493 1787
1494 return find "~" . $ob->name . "/" . $self->{path} 1788 return find "~" . $ob->name . "/" . $self->{path}
1495 if $self->per_player; 1789 if $self->per_player;
1790
1791# return find "?party/" . $ob->name . "/" . $self->{path}
1792# if $self->per_party;
1496 1793
1497 $self 1794 $self
1498} 1795}
1499 1796
1500# find and load all maps in the 3x3 area around a map 1797# find and load all maps in the 3x3 area around a map
… …
1611 1908
1612sub reset_at { 1909sub reset_at {
1613 my ($self) = @_; 1910 my ($self) = @_;
1614 1911
1615 # TODO: safety, remove and allow resettable per-player maps 1912 # TODO: safety, remove and allow resettable per-player maps
1616 return 1e99 if $self->isa ("ext::map_per_player");#d#
1617 return 1e99 if $self->{deny_reset}; 1913 return 1e99 if $self->{deny_reset};
1618 1914
1619 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1915 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1620 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1916 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1621 1917
… …
1632 my ($self) = @_; 1928 my ($self) = @_;
1633 1929
1634 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1930 my $lock = cf::lock_acquire "map_data:$self->{path}";
1635 1931
1636 return if $self->players; 1932 return if $self->players;
1637 return if $self->isa ("ext::map_per_player");#d#
1638 1933
1639 warn "resetting map ", $self->path;#d# 1934 warn "resetting map ", $self->path;
1640 1935
1641 $self->in_memory (cf::MAP_SWAPPED); 1936 $self->in_memory (cf::MAP_SWAPPED);
1642 1937
1643 # need to save uniques path 1938 # need to save uniques path
1644 unless ($self->{deny_save}) { 1939 unless ($self->{deny_save}) {
… …
1676 $cf::MAP{$self->path} = $self; 1971 $cf::MAP{$self->path} = $self;
1677 1972
1678 $self->reset; # polite request, might not happen 1973 $self->reset; # polite request, might not happen
1679} 1974}
1680 1975
1976=item $maps = cf::map::tmp_maps
1977
1978Returns an arrayref with all map paths of currently instantiated and saved
1979maps. May block.
1980
1981=cut
1982
1983sub tmp_maps() {
1984 [
1985 map {
1986 utf8::decode $_;
1987 /\.map$/
1988 ? normalise $_
1989 : ()
1990 } @{ aio_readdir $TMPDIR or [] }
1991 ]
1992}
1993
1994=item $maps = cf::map::random_maps
1995
1996Returns an arrayref with all map paths of currently instantiated and saved
1997random maps. May block.
1998
1999=cut
2000
2001sub random_maps() {
2002 [
2003 map {
2004 utf8::decode $_;
2005 /\.map$/
2006 ? normalise "?random/$_"
2007 : ()
2008 } @{ aio_readdir $RANDOMDIR or [] }
2009 ]
2010}
2011
1681=item cf::map::unique_maps 2012=item cf::map::unique_maps
1682 2013
1683Returns an arrayref of paths of all shared maps that have 2014Returns an arrayref of paths of all shared maps that have
1684instantiated unique items. May block. 2015instantiated unique items. May block.
1685 2016
1686=cut 2017=cut
1687 2018
1688sub unique_maps() { 2019sub unique_maps() {
1689 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2020 [
1690 or return; 2021 map {
1691
1692 my @paths;
1693
1694 for (@$files) {
1695 utf8::decode $_; 2022 utf8::decode $_;
1696 next if /\.pst$/; 2023 /\.map$/
1697 next unless /^$PATH_SEP/o; 2024 ? normalise $_
1698 2025 : ()
1699 push @paths, cf::map::normalise $_; 2026 } @{ aio_readdir $UNIQUEDIR or [] }
1700 } 2027 ]
1701
1702 \@paths
1703} 2028}
1704 2029
1705package cf; 2030package cf;
1706 2031
1707=back 2032=back
… …
1753 2078
1754 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2079 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1755 2080
1756 if ($self->{record_replies}) { 2081 if ($self->{record_replies}) {
1757 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2082 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2083
1758 } else { 2084 } else {
2085 my $pl = $self->contr;
2086
2087 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2088 my $diag = $pl->{npc_dialog};
2089 $diag->{pl}->ext_reply (
2090 $diag->{id},
2091 msgtype => "reply",
2092 msg => $diag->{pl}->expand_cfpod ($msg),
2093 add_topics => []
2094 );
2095
2096 } else {
1759 $msg = $npc->name . " says: $msg" if $npc; 2097 $msg = $npc->name . " says: $msg" if $npc;
1760 $self->message ($msg, $flags); 2098 $self->message ($msg, $flags);
2099 }
1761 } 2100 }
1762} 2101}
1763 2102
1764=item $player_object->may ("access") 2103=item $player_object->may ("access")
1765 2104
… …
1813 $self->deactivate_recursive; 2152 $self->deactivate_recursive;
1814 2153
1815 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2154 return if UNIVERSAL::isa $self->map, "ext::map_link";
1816 2155
1817 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2156 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1818 if $self->map; 2157 if $self->map && $self->map->{path} ne "{link}";
1819 2158
1820 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2159 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1821} 2160}
1822 2161
1823sub cf::object::player::leave_link { 2162sub cf::object::player::leave_link {
1824 my ($self, $map, $x, $y) = @_; 2163 my ($self, $map, $x, $y) = @_;
2164
2165 return unless $self->contr->active;
1825 2166
1826 my $link_pos = delete $self->{_link_pos}; 2167 my $link_pos = delete $self->{_link_pos};
1827 2168
1828 unless ($map) { 2169 unless ($map) {
1829 # restore original map position 2170 # restore original map position
… …
1852 2193
1853 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2194 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1854 $self->enter_map ($map, $x, $y); 2195 $self->enter_map ($map, $x, $y);
1855} 2196}
1856 2197
1857cf::player->attach (
1858 on_logout => sub {
1859 my ($pl) = @_;
1860
1861 # abort map switching before logout
1862 if ($pl->ob->{_link_pos}) {
1863 cf::sync_job {
1864 $pl->ob->leave_link
1865 };
1866 }
1867 },
1868 on_login => sub {
1869 my ($pl) = @_;
1870
1871 # try to abort aborted map switching on player login :)
1872 # should happen only on crashes
1873 if ($pl->ob->{_link_pos}) {
1874 $pl->ob->enter_link;
1875 (async {
1876 $pl->ob->reply (undef,
1877 "There was an internal problem at your last logout, "
1878 . "the server will try to bring you to your intended destination in a second.",
1879 cf::NDI_RED);
1880 # we need this sleep as the login has a concurrent enter_exit running
1881 # and this sleep increases chances of the player not ending up in scorn
1882 Coro::Timer::sleep 1;
1883 $pl->ob->leave_link;
1884 })->prio (2);
1885 }
1886 },
1887);
1888
1889=item $player_object->goto ($path, $x, $y) 2198=item $player_object->goto ($path, $x, $y[, $check->($map)])
1890 2199
2200Moves the player to the given map-path and coordinates by first freezing
2201her, loading and preparing them map, calling the provided $check callback
2202that has to return the map if sucecssful, and then unfreezes the player on
2203the new (success) or old (failed) map position.
2204
1891=cut 2205=cut
2206
2207our $GOTOGEN;
1892 2208
1893sub cf::object::player::goto { 2209sub cf::object::player::goto {
1894 my ($self, $path, $x, $y) = @_; 2210 my ($self, $path, $x, $y, $check) = @_;
2211
2212 # do generation counting so two concurrent goto's will be executed in-order
2213 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1895 2214
1896 $self->enter_link; 2215 $self->enter_link;
1897 2216
1898 (async { 2217 (async {
1899 my $map = eval { 2218 my $map = eval {
1900 my $map = cf::map::find $path; 2219 my $map = cf::map::find $path;
2220
2221 if ($map) {
1901 $map = $map->customise_for ($self) if $map; 2222 $map = $map->customise_for ($self);
2223 $map = $check->($map) if $check && $map;
2224 } else {
2225 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2226 }
2227
1902 $map 2228 $map
2229 };
2230
2231 if ($@) {
2232 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2233 LOG llevError | logBacktrace, Carp::longmess $@;
1903 } or 2234 }
1904 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1905 2235
2236 if ($gen == $self->{_goto_generation}) {
2237 delete $self->{_goto_generation};
1906 $self->leave_link ($map, $x, $y); 2238 $self->leave_link ($map, $x, $y);
2239 }
1907 })->prio (1); 2240 })->prio (1);
1908} 2241}
1909 2242
1910=item $player_object->enter_exit ($exit_object) 2243=item $player_object->enter_exit ($exit_object)
1911 2244
… …
1950 2283
1951 $rmp->{random_seed} ||= $exit->random_seed; 2284 $rmp->{random_seed} ||= $exit->random_seed;
1952 2285
1953 my $data = cf::to_json $rmp; 2286 my $data = cf::to_json $rmp;
1954 my $md5 = Digest::MD5::md5_hex $data; 2287 my $md5 = Digest::MD5::md5_hex $data;
1955 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2288 my $meta = "$RANDOMDIR/$md5.meta";
1956 2289
1957 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2290 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1958 aio_write $fh, 0, (length $data), $data, 0; 2291 aio_write $fh, 0, (length $data), $data, 0;
1959 undef $fh; 2292 undef $fh;
1960 aio_rename "$meta~", $meta; 2293 aio_rename "$meta~", $meta;
… …
1969 2302
1970 return unless $self->type == cf::PLAYER; 2303 return unless $self->type == cf::PLAYER;
1971 2304
1972 if ($exit->slaying eq "/!") { 2305 if ($exit->slaying eq "/!") {
1973 #TODO: this should de-fi-ni-te-ly not be a sync-job 2306 #TODO: this should de-fi-ni-te-ly not be a sync-job
2307 # the problem is that $exit might not survive long enough
2308 # so it needs to be done right now, right here
1974 cf::sync_job { prepare_random_map $exit }; 2309 cf::sync_job { prepare_random_map $exit };
1975 } 2310 }
1976 2311
1977 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2312 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1978 my $hp = $exit->stats->hp; 2313 my $hp = $exit->stats->hp;
… …
1986 $self->goto ($slaying, $hp, $sp); 2321 $self->goto ($slaying, $hp, $sp);
1987 2322
1988 1; 2323 1;
1989 }) { 2324 }) {
1990 $self->message ("Something went wrong deep within the crossfire server. " 2325 $self->message ("Something went wrong deep within the crossfire server. "
1991 . "I'll try to bring you back to the map you were before. " 2326 . "I'll try to bring you back to the map you were before. "
1992 . "Please report this to the dungeon master!", 2327 . "Please report this to the dungeon master!",
1993 cf::NDI_UNIQUE | cf::NDI_RED); 2328 cf::NDI_UNIQUE | cf::NDI_RED);
1994 2329
1995 warn "ERROR in enter_exit: $@"; 2330 warn "ERROR in enter_exit: $@";
1996 $self->leave_link; 2331 $self->leave_link;
1997 } 2332 }
1998 })->prio (1); 2333 })->prio (1);
… …
2014 2349
2015 utf8::encode $text; 2350 utf8::encode $text;
2016 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2351 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2017} 2352}
2018 2353
2354=item $client->send_msg ($color, $type, $msg, [extra...])
2355
2356Send a drawinfo or msg packet to the client, formatting the msg for the
2357client if neccessary. C<$type> should be a string identifying the type of
2358the message, with C<log> being the default. If C<$color> is negative, suppress
2359the message unless the client supports the msg packet.
2360
2361=cut
2362
2363sub cf::client::send_msg {
2364 my ($self, $color, $type, $msg, @extra) = @_;
2365
2366 $msg = $self->pl->expand_cfpod ($msg);
2367
2368 if ($self->can_msg) {
2369 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2370 } else {
2371 # replace some tags by gcfclient-compatible ones
2372 for ($msg) {
2373 1 while
2374 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2375 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2376 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2377 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2378 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${1}[\/color]/;
2379 }
2380
2381 if ($color >= 0) {
2382 if ($msg =~ /\[/) {
2383 $self->send_packet ("drawextinfo $color 4 0 $msg")
2384 } else {
2385 $self->send_packet ("drawinfo $color $msg")
2386 }
2387 }
2388 }
2389}
2390
2391=item $client->ext_event ($type, %msg)
2392
2393Sends an exti event to the client.
2394
2395=cut
2396
2397sub cf::client::ext_event($$%) {
2398 my ($self, $type, %msg) = @_;
2399
2400 $msg{msgtype} = "event_$type";
2401 $self->send_packet ("ext " . cf::to_json \%msg);
2402}
2019 2403
2020=item $success = $client->query ($flags, "text", \&cb) 2404=item $success = $client->query ($flags, "text", \&cb)
2021 2405
2022Queues a query to the client, calling the given callback with 2406Queues a query to the client, calling the given callback with
2023the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2407the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
… …
2211=back 2595=back
2212 2596
2213=cut 2597=cut
2214 2598
2215############################################################################# 2599#############################################################################
2216
2217=head2 EXTENSION DATABASE SUPPORT
2218
2219Crossfire maintains a very simple database for extension use. It can
2220currently store anything that can be serialised using Storable, which
2221excludes objects.
2222
2223The parameter C<$family> should best start with the name of the extension
2224using it, it should be unique.
2225
2226=over 4
2227
2228=item $value = cf::db_get $family => $key
2229
2230Returns a single value from the database.
2231
2232=item cf::db_put $family => $key => $value
2233
2234Stores the given C<$value> in the family.
2235
2236=cut
2237
2238our $DB;
2239
2240sub db_init {
2241 unless ($DB) {
2242 $DB = BDB::db_create $DB_ENV;
2243
2244 cf::sync_job {
2245 eval {
2246 $DB->set_flags (BDB::CHKSUM);
2247
2248 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2249 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2250 cf::cleanup "db_open(db): $!" if $!;
2251 };
2252 cf::cleanup "db_open(db): $@" if $@;
2253 };
2254
2255 my $path = cf::localdir . "/database.pst";
2256 if (stat $path) {
2257 cf::sync_job {
2258 my $pst = Storable::retrieve $path;
2259
2260 cf::db_put (board => data => $pst->{board});
2261 cf::db_put (guildrules => data => $pst->{guildrules});
2262 cf::db_put (rent => balance => $pst->{rent}{balance});
2263 BDB::db_env_txn_checkpoint $DB_ENV;
2264
2265 unlink $path;
2266 };
2267 }
2268 }
2269}
2270
2271sub db_get($$) {
2272 my $key = "$_[0]/$_[1]";
2273
2274 cf::sync_job {
2275 BDB::db_get $DB, undef, $key, my $data;
2276
2277 $! ? ()
2278 : Compress::LZF::sthaw $data
2279 }
2280}
2281
2282sub db_put($$$) {
2283 BDB::dbreq_pri 4;
2284 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2285}
2286
2287#############################################################################
2288# the server's init and main functions 2600# the server's init and main functions
2289 2601
2290sub load_facedata { 2602sub load_facedata($) {
2291 my $path = sprintf "%s/facedata", cf::datadir; 2603 my ($path) = @_;
2292 2604
2293 warn "loading facedata from $path\n"; 2605 warn "loading facedata from $path\n";
2294 2606
2295 my $faces; 2607 my $facedata;
2296 0 < aio_load $path, $faces 2608 0 < aio_load $path, $facedata
2297 or die "$path: $!"; 2609 or die "$path: $!";
2298 2610
2299 Coro::cede;
2300 $faces = Storable::thaw $faces; 2611 $facedata = Coro::Storable::thaw $facedata;
2301 Coro::cede;
2302 2612
2303 my $meta = delete $faces->{""};
2304 $meta->{version} == 1 2613 $facedata->{version} == 2
2305 or cf::cleanup "$path: version mismatch, cannot proceed."; 2614 or cf::cleanup "$path: version mismatch, cannot proceed.";
2306 2615
2616 {
2617 my $faces = $facedata->{faceinfo};
2618
2307 while (my ($face, $info) = each %$faces) { 2619 while (my ($face, $info) = each %$faces) {
2308 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2620 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2309 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2621 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2310 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2622 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2311 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2623 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2312 Coro::cede; 2624 Coro::cede;
2313 } 2625 }
2314 2626
2315 while (my ($face, $info) = each %$faces) { 2627 while (my ($face, $info) = each %$faces) {
2316 next unless $info->{smooth}; 2628 next unless $info->{smooth};
2317 my $idx = cf::face::find $face 2629 my $idx = cf::face::find $face
2318 or next; 2630 or next;
2319 if (my $smooth = cf::face::find $info->{smooth}) { 2631 if (my $smooth = cf::face::find $info->{smooth}) {
2320 cf::face::set_smooth $idx, $smooth; 2632 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2321 } else { 2633 } else {
2322 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2634 warn "smooth face '$info->{smooth}' not found for face '$face'";
2323 } 2635 }
2324 Coro::cede; 2636 Coro::cede;
2637 }
2638 }
2639
2640 {
2641 my $anims = $facedata->{animinfo};
2642
2643 while (my ($anim, $info) = each %$anims) {
2644 cf::anim::set $anim, $info->{frames}, $info->{facings};
2645 Coro::cede;
2646 }
2647
2648 cf::anim::invalidate_all; # d'oh
2325 } 2649 }
2326 2650
2327 1 2651 1
2328} 2652}
2329 2653
2654sub reload_regions {
2655 load_resource_file "$MAPDIR/regions"
2656 or die "unable to load regions file\n";
2657}
2658
2659sub reload_facedata {
2660 load_facedata "$DATADIR/facedata"
2661 or die "unable to load facedata\n";
2662}
2663
2664sub reload_archetypes {
2665 load_resource_file "$DATADIR/archetypes"
2666 or die "unable to load archetypes\n";
2667}
2668
2669sub reload_treasures {
2670 load_resource_file "$DATADIR/treasures"
2671 or die "unable to load treasurelists\n";
2672}
2673
2330sub reload_resources { 2674sub reload_resources {
2331 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 2675 warn "reloading resource files...\n";
2332 or die "unable to load regions file\n";#d# 2676
2677 reload_regions;
2333 load_facedata 2678 reload_facedata;
2334 or die "unable to load facedata\n";#d# 2679 #reload_archetypes;#d#
2680 reload_archetypes;
2681 reload_treasures;
2682
2683 warn "finished reloading resource files\n";
2335} 2684}
2336 2685
2337sub init { 2686sub init {
2338 reload_resources; 2687 reload_resources;
2339} 2688}
2340 2689
2341sub cfg_load { 2690sub cfg_load {
2342 open my $fh, "<:utf8", cf::confdir . "/config" 2691 open my $fh, "<:utf8", "$CONFDIR/config"
2343 or return; 2692 or return;
2344 2693
2345 local $/; 2694 local $/;
2346 *CFG = YAML::Syck::Load <$fh>; 2695 *CFG = YAML::Syck::Load <$fh>;
2347 2696
… …
2392 }, 2741 },
2393 ); 2742 );
2394 } 2743 }
2395} 2744}
2396 2745
2746sub write_runtime {
2747 my $runtime = "$LOCALDIR/runtime";
2748
2749 # first touch the runtime file to show we are still running:
2750 # the fsync below can take a very very long time.
2751
2752 IO::AIO::aio_utime $runtime, undef, undef;
2753
2754 my $guard = cf::lock_acquire "write_runtime";
2755
2756 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2757 or return;
2758
2759 my $value = $cf::RUNTIME + 90 + 10;
2760 # 10 is the runtime save interval, for a monotonic clock
2761 # 60 allows for the watchdog to kill the server.
2762
2763 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2764 and return;
2765
2766 # always fsync - this file is important
2767 aio_fsync $fh
2768 and return;
2769
2770 # touch it again to show we are up-to-date
2771 aio_utime $fh, undef, undef;
2772
2773 close $fh
2774 or return;
2775
2776 aio_rename "$runtime~", $runtime
2777 and return;
2778
2779 warn "runtime file written.\n";
2780
2781 1
2782}
2783
2397sub emergency_save() { 2784sub emergency_save() {
2398 my $freeze_guard = cf::freeze_mainloop; 2785 my $freeze_guard = cf::freeze_mainloop;
2399 2786
2400 warn "enter emergency perl save\n"; 2787 warn "enter emergency perl save\n";
2401 2788
… …
2432 2819
2433 warn Carp::longmess "post_cleanup backtrace" 2820 warn Carp::longmess "post_cleanup backtrace"
2434 if $make_core; 2821 if $make_core;
2435} 2822}
2436 2823
2437sub reload() { 2824sub do_reload_perl() {
2438 # can/must only be called in main 2825 # can/must only be called in main
2439 if ($Coro::current != $Coro::main) { 2826 if ($Coro::current != $Coro::main) {
2440 warn "can only reload from main coroutine"; 2827 warn "can only reload from main coroutine";
2441 return; 2828 return;
2442 } 2829 }
… …
2517 Symbol::delete_package "safe::$_" 2904 Symbol::delete_package "safe::$_"
2518 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2905 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2519 2906
2520 warn "unloading cf.pm \"a bit\""; 2907 warn "unloading cf.pm \"a bit\"";
2521 delete $INC{"cf.pm"}; 2908 delete $INC{"cf.pm"};
2909 delete $INC{"cf/pod.pm"};
2522 2910
2523 # don't, removes xs symbols, too, 2911 # don't, removes xs symbols, too,
2524 # and global variables created in xs 2912 # and global variables created in xs
2525 #Symbol::delete_package __PACKAGE__; 2913 #Symbol::delete_package __PACKAGE__;
2526 2914
… …
2541 warn "reattaching attachments to maps"; 2929 warn "reattaching attachments to maps";
2542 reattach $_ for values %MAP; 2930 reattach $_ for values %MAP;
2543 warn "reattaching attachments to players"; 2931 warn "reattaching attachments to players";
2544 reattach $_ for values %PLAYER; 2932 reattach $_ for values %PLAYER;
2545 2933
2546 warn "loading reloadable resources";
2547 reload_resources;
2548
2549 warn "leaving sync_job"; 2934 warn "leaving sync_job";
2550 2935
2551 1 2936 1
2552 } or do { 2937 } or do {
2553 warn $@; 2938 warn $@;
… …
2558 warn "reloaded"; 2943 warn "reloaded";
2559}; 2944};
2560 2945
2561our $RELOAD_WATCHER; # used only during reload 2946our $RELOAD_WATCHER; # used only during reload
2562 2947
2948sub reload_perl() {
2949 # doing reload synchronously and two reloads happen back-to-back,
2950 # coro crashes during coro_state_free->destroy here.
2951
2952 $RELOAD_WATCHER ||= Event->timer (
2953 reentrant => 0,
2954 after => 0,
2955 data => WF_AUTOCANCEL,
2956 cb => sub {
2957 do_reload_perl;
2958 undef $RELOAD_WATCHER;
2959 },
2960 );
2961}
2962
2563register_command "reload" => sub { 2963register_command "reload" => sub {
2564 my ($who, $arg) = @_; 2964 my ($who, $arg) = @_;
2565 2965
2566 if ($who->flag (FLAG_WIZ)) { 2966 if ($who->flag (FLAG_WIZ)) {
2567 $who->message ("reloading server."); 2967 $who->message ("reloading server.");
2568 2968 async { reload_perl };
2569 # doing reload synchronously and two reloads happen back-to-back,
2570 # coro crashes during coro_state_free->destroy here.
2571
2572 $RELOAD_WATCHER ||= Event->timer (
2573 reentrant => 0,
2574 after => 0,
2575 data => WF_AUTOCANCEL,
2576 cb => sub {
2577 reload;
2578 undef $RELOAD_WATCHER;
2579 },
2580 );
2581 } 2969 }
2582}; 2970};
2583 2971
2584unshift @INC, $LIBDIR; 2972unshift @INC, $LIBDIR;
2585 2973
2586my $bug_warning = 0; 2974my $bug_warning = 0;
2587 2975
2976our @WAIT_FOR_TICK;
2977our @WAIT_FOR_TICK_BEGIN;
2978
2979sub wait_for_tick {
2980 return unless $TICK_WATCHER->is_active;
2981 return if $Coro::current == $Coro::main;
2982
2983 my $signal = new Coro::Signal;
2984 push @WAIT_FOR_TICK, $signal;
2985 $signal->wait;
2986}
2987
2988sub wait_for_tick_begin {
2989 return unless $TICK_WATCHER->is_active;
2990 return if $Coro::current == $Coro::main;
2991
2992 my $signal = new Coro::Signal;
2993 push @WAIT_FOR_TICK_BEGIN, $signal;
2994 $signal->wait;
2995}
2996
2997 my $min = 1e6;#d#
2998 my $avg = 10;
2588$TICK_WATCHER = Event->timer ( 2999$TICK_WATCHER = Event->timer (
2589 reentrant => 0, 3000 reentrant => 0,
2590 parked => 1, 3001 parked => 1,
2591 prio => 0, 3002 prio => 0,
2592 at => $NEXT_TICK || $TICK, 3003 at => $NEXT_TICK || $TICK,
… …
2596 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3007 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2597 unless ++$bug_warning > 10; 3008 unless ++$bug_warning > 10;
2598 return; 3009 return;
2599 } 3010 }
2600 3011
2601 $NOW = Event::time; 3012 $NOW = $tick_start = Event::time;
2602 3013
2603 cf::server_tick; # one server iteration 3014 cf::server_tick; # one server iteration
3015
3016 0 && sync_job {#d#
3017 for(1..10) {
3018 my $t = Event::time;
3019 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3020 or die;
3021
3022 $map->width (50);
3023 $map->height (50);
3024 $map->alloc;
3025 $map->_load_objects ("/tmp/x.map", 1);
3026 my $t = Event::time - $t;
3027
3028 #next unless $t < 0.0013;#d#
3029 if ($t < $min) {
3030 $min = $t;
3031 }
3032 $avg = $avg * 0.99 + $t * 0.01;
3033 }
3034 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3035 exit 0;
3036 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3037 };
3038
2604 $RUNTIME += $TICK; 3039 $RUNTIME += $TICK;
2605 $NEXT_TICK += $TICK; 3040 $NEXT_TICK += $TICK;
2606 3041
2607 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3042 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2608 $NEXT_RUNTIME_WRITE = $NOW + 10; 3043 $NEXT_RUNTIME_WRITE = $NOW + 10;
… …
2610 write_runtime 3045 write_runtime
2611 or warn "ERROR: unable to write runtime file: $!"; 3046 or warn "ERROR: unable to write runtime file: $!";
2612 }; 3047 };
2613 } 3048 }
2614 3049
2615 $WAIT_FOR_TICK->broadcast;
2616 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2617
2618# my $AFTER = Event::time; 3050# my $AFTER = Event::time;
2619# warn $AFTER - $NOW;#d# 3051# warn $AFTER - $NOW;#d#
2620 3052
3053 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3054 $sig->send;
3055 }
3056 while (my $sig = shift @WAIT_FOR_TICK) {
3057 $sig->send;
3058 }
3059
3060 $NOW = Event::time;
3061
2621 # if we are delayed by four ticks or more, skip them all 3062 # if we are delayed by four ticks or more, skip them all
2622 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3063 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2623 3064
2624 $TICK_WATCHER->at ($NEXT_TICK); 3065 $TICK_WATCHER->at ($NEXT_TICK);
2625 $TICK_WATCHER->start; 3066 $TICK_WATCHER->start;
3067
3068 $LOAD = ($NOW - $tick_start) / $TICK;
3069 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3070
3071 _post_tick;
3072
3073
2626 }, 3074 },
2627); 3075);
2628 3076
2629{ 3077{
2630 BDB::max_poll_time $TICK * 0.1; 3078 BDB::max_poll_time $TICK * 0.1;
… …
2658 3106
2659 cf::sync_job { 3107 cf::sync_job {
2660 eval { 3108 eval {
2661 BDB::db_env_open 3109 BDB::db_env_open
2662 $DB_ENV, 3110 $DB_ENV,
2663 $BDB_ENV_DIR, 3111 $BDBDIR,
2664 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3112 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2665 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3113 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2666 0666; 3114 0666;
2667 3115
2668 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3116 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2669 3117
2670 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3118 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2671 $DB_ENV->set_lk_detect; 3119 $DB_ENV->set_lk_detect;
2672 }; 3120 };
2673 3121
… …
2689 prio => 6, 3137 prio => 6,
2690 cb => \&IO::AIO::poll_cb, 3138 cb => \&IO::AIO::poll_cb,
2691 ); 3139 );
2692} 3140}
2693 3141
3142my $_log_backtrace;
3143
3144sub _log_backtrace {
3145 my ($msg, @addr) = @_;
3146
3147 $msg =~ s/\n//;
3148
3149 # limit the # of concurrent backtraces
3150 if ($_log_backtrace < 2) {
3151 ++$_log_backtrace;
3152 async {
3153 my @bt = fork_call {
3154 @addr = map { sprintf "%x", $_ } @addr;
3155 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3156 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3157 or die "addr2line: $!";
3158
3159 my @funcs;
3160 my @res = <$fh>;
3161 chomp for @res;
3162 while (@res) {
3163 my ($func, $line) = splice @res, 0, 2, ();
3164 push @funcs, "[$func] $line";
3165 }
3166
3167 @funcs
3168 };
3169
3170 LOG llevInfo, "[ABT] $msg\n";
3171 LOG llevInfo, "[ABT] $_\n" for @bt;
3172 --$_log_backtrace;
3173 };
3174 } else {
3175 LOG llevInfo, "[ABT] $msg\n";
3176 LOG llevInfo, "[ABT] [suppressed]\n";
3177 }
3178}
3179
3180# load additional modules
3181use cf::pod;
3182
2694END { cf::emergency_save } 3183END { cf::emergency_save }
2695 3184
26961 31851
2697 3186

Diff Legend

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