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.285 by root, Sun Jun 24 04:21:42 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]${2}[\/color]/;
2379 }
2380
2381 if ($color >= 0) {
2382 if (0 && $msg =~ /\[/) {
2383 $self->send_packet ("drawextinfo $color 4 0 $msg")
2384 } else {
2385 s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2386 $self->send_packet ("drawinfo $color $msg")
2387 }
2388 }
2389 }
2390}
2391
2392=item $client->ext_event ($type, %msg)
2393
2394Sends an exti event to the client.
2395
2396=cut
2397
2398sub cf::client::ext_event($$%) {
2399 my ($self, $type, %msg) = @_;
2400
2401 $msg{msgtype} = "event_$type";
2402 $self->send_packet ("ext " . cf::to_json \%msg);
2403}
2019 2404
2020=item $success = $client->query ($flags, "text", \&cb) 2405=item $success = $client->query ($flags, "text", \&cb)
2021 2406
2022Queues a query to the client, calling the given callback with 2407Queues a query to the client, calling the given callback with
2023the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2408the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
… …
2211=back 2596=back
2212 2597
2213=cut 2598=cut
2214 2599
2215############################################################################# 2600#############################################################################
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 2601# the server's init and main functions
2289 2602
2290sub load_facedata { 2603sub load_facedata($) {
2291 my $path = sprintf "%s/facedata", cf::datadir; 2604 my ($path) = @_;
2292 2605
2293 warn "loading facedata from $path\n"; 2606 warn "loading facedata from $path\n";
2294 2607
2295 my $faces; 2608 my $facedata;
2296 0 < aio_load $path, $faces 2609 0 < aio_load $path, $facedata
2297 or die "$path: $!"; 2610 or die "$path: $!";
2298 2611
2299 Coro::cede;
2300 $faces = Storable::thaw $faces; 2612 $facedata = Coro::Storable::thaw $facedata;
2301 Coro::cede;
2302 2613
2303 my $meta = delete $faces->{""};
2304 $meta->{version} == 1 2614 $facedata->{version} == 2
2305 or cf::cleanup "$path: version mismatch, cannot proceed."; 2615 or cf::cleanup "$path: version mismatch, cannot proceed.";
2306 2616
2617 {
2618 my $faces = $facedata->{faceinfo};
2619
2307 while (my ($face, $info) = each %$faces) { 2620 while (my ($face, $info) = each %$faces) {
2308 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2621 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2309 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2622 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2310 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2623 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2311 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2624 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2312 Coro::cede; 2625 Coro::cede;
2313 } 2626 }
2314 2627
2315 while (my ($face, $info) = each %$faces) { 2628 while (my ($face, $info) = each %$faces) {
2316 next unless $info->{smooth}; 2629 next unless $info->{smooth};
2317 my $idx = cf::face::find $face 2630 my $idx = cf::face::find $face
2318 or next; 2631 or next;
2319 if (my $smooth = cf::face::find $info->{smooth}) { 2632 if (my $smooth = cf::face::find $info->{smooth}) {
2320 cf::face::set_smooth $idx, $smooth; 2633 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2321 } else { 2634 } else {
2322 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2635 warn "smooth face '$info->{smooth}' not found for face '$face'";
2323 } 2636 }
2324 Coro::cede; 2637 Coro::cede;
2638 }
2639 }
2640
2641 {
2642 my $anims = $facedata->{animinfo};
2643
2644 while (my ($anim, $info) = each %$anims) {
2645 cf::anim::set $anim, $info->{frames}, $info->{facings};
2646 Coro::cede;
2647 }
2648
2649 cf::anim::invalidate_all; # d'oh
2325 } 2650 }
2326 2651
2327 1 2652 1
2328} 2653}
2329 2654
2655sub reload_regions {
2656 load_resource_file "$MAPDIR/regions"
2657 or die "unable to load regions file\n";
2658}
2659
2660sub reload_facedata {
2661 load_facedata "$DATADIR/facedata"
2662 or die "unable to load facedata\n";
2663}
2664
2665sub reload_archetypes {
2666 load_resource_file "$DATADIR/archetypes"
2667 or die "unable to load archetypes\n";
2668}
2669
2670sub reload_treasures {
2671 load_resource_file "$DATADIR/treasures"
2672 or die "unable to load treasurelists\n";
2673}
2674
2330sub reload_resources { 2675sub reload_resources {
2331 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 2676 warn "reloading resource files...\n";
2332 or die "unable to load regions file\n";#d# 2677
2678 reload_regions;
2333 load_facedata 2679 reload_facedata;
2334 or die "unable to load facedata\n";#d# 2680 #reload_archetypes;#d#
2681 reload_archetypes;
2682 reload_treasures;
2683
2684 warn "finished reloading resource files\n";
2335} 2685}
2336 2686
2337sub init { 2687sub init {
2338 reload_resources; 2688 reload_resources;
2339} 2689}
2340 2690
2341sub cfg_load { 2691sub cfg_load {
2342 open my $fh, "<:utf8", cf::confdir . "/config" 2692 open my $fh, "<:utf8", "$CONFDIR/config"
2343 or return; 2693 or return;
2344 2694
2345 local $/; 2695 local $/;
2346 *CFG = YAML::Syck::Load <$fh>; 2696 *CFG = YAML::Syck::Load <$fh>;
2347 2697
… …
2392 }, 2742 },
2393 ); 2743 );
2394 } 2744 }
2395} 2745}
2396 2746
2747sub write_runtime {
2748 my $runtime = "$LOCALDIR/runtime";
2749
2750 # first touch the runtime file to show we are still running:
2751 # the fsync below can take a very very long time.
2752
2753 IO::AIO::aio_utime $runtime, undef, undef;
2754
2755 my $guard = cf::lock_acquire "write_runtime";
2756
2757 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2758 or return;
2759
2760 my $value = $cf::RUNTIME + 90 + 10;
2761 # 10 is the runtime save interval, for a monotonic clock
2762 # 60 allows for the watchdog to kill the server.
2763
2764 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2765 and return;
2766
2767 # always fsync - this file is important
2768 aio_fsync $fh
2769 and return;
2770
2771 # touch it again to show we are up-to-date
2772 aio_utime $fh, undef, undef;
2773
2774 close $fh
2775 or return;
2776
2777 aio_rename "$runtime~", $runtime
2778 and return;
2779
2780 warn "runtime file written.\n";
2781
2782 1
2783}
2784
2397sub emergency_save() { 2785sub emergency_save() {
2398 my $freeze_guard = cf::freeze_mainloop; 2786 my $freeze_guard = cf::freeze_mainloop;
2399 2787
2400 warn "enter emergency perl save\n"; 2788 warn "enter emergency perl save\n";
2401 2789
… …
2432 2820
2433 warn Carp::longmess "post_cleanup backtrace" 2821 warn Carp::longmess "post_cleanup backtrace"
2434 if $make_core; 2822 if $make_core;
2435} 2823}
2436 2824
2437sub reload() { 2825sub do_reload_perl() {
2438 # can/must only be called in main 2826 # can/must only be called in main
2439 if ($Coro::current != $Coro::main) { 2827 if ($Coro::current != $Coro::main) {
2440 warn "can only reload from main coroutine"; 2828 warn "can only reload from main coroutine";
2441 return; 2829 return;
2442 } 2830 }
… …
2517 Symbol::delete_package "safe::$_" 2905 Symbol::delete_package "safe::$_"
2518 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2906 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2519 2907
2520 warn "unloading cf.pm \"a bit\""; 2908 warn "unloading cf.pm \"a bit\"";
2521 delete $INC{"cf.pm"}; 2909 delete $INC{"cf.pm"};
2910 delete $INC{"cf/pod.pm"};
2522 2911
2523 # don't, removes xs symbols, too, 2912 # don't, removes xs symbols, too,
2524 # and global variables created in xs 2913 # and global variables created in xs
2525 #Symbol::delete_package __PACKAGE__; 2914 #Symbol::delete_package __PACKAGE__;
2526 2915
… …
2541 warn "reattaching attachments to maps"; 2930 warn "reattaching attachments to maps";
2542 reattach $_ for values %MAP; 2931 reattach $_ for values %MAP;
2543 warn "reattaching attachments to players"; 2932 warn "reattaching attachments to players";
2544 reattach $_ for values %PLAYER; 2933 reattach $_ for values %PLAYER;
2545 2934
2546 warn "loading reloadable resources";
2547 reload_resources;
2548
2549 warn "leaving sync_job"; 2935 warn "leaving sync_job";
2550 2936
2551 1 2937 1
2552 } or do { 2938 } or do {
2553 warn $@; 2939 warn $@;
… …
2558 warn "reloaded"; 2944 warn "reloaded";
2559}; 2945};
2560 2946
2561our $RELOAD_WATCHER; # used only during reload 2947our $RELOAD_WATCHER; # used only during reload
2562 2948
2949sub reload_perl() {
2950 # doing reload synchronously and two reloads happen back-to-back,
2951 # coro crashes during coro_state_free->destroy here.
2952
2953 $RELOAD_WATCHER ||= Event->timer (
2954 reentrant => 0,
2955 after => 0,
2956 data => WF_AUTOCANCEL,
2957 cb => sub {
2958 do_reload_perl;
2959 undef $RELOAD_WATCHER;
2960 },
2961 );
2962}
2963
2563register_command "reload" => sub { 2964register_command "reload" => sub {
2564 my ($who, $arg) = @_; 2965 my ($who, $arg) = @_;
2565 2966
2566 if ($who->flag (FLAG_WIZ)) { 2967 if ($who->flag (FLAG_WIZ)) {
2567 $who->message ("reloading server."); 2968 $who->message ("reloading server.");
2568 2969 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 } 2970 }
2582}; 2971};
2583 2972
2584unshift @INC, $LIBDIR; 2973unshift @INC, $LIBDIR;
2585 2974
2586my $bug_warning = 0; 2975my $bug_warning = 0;
2587 2976
2977our @WAIT_FOR_TICK;
2978our @WAIT_FOR_TICK_BEGIN;
2979
2980sub wait_for_tick {
2981 return unless $TICK_WATCHER->is_active;
2982 return if $Coro::current == $Coro::main;
2983
2984 my $signal = new Coro::Signal;
2985 push @WAIT_FOR_TICK, $signal;
2986 $signal->wait;
2987}
2988
2989sub wait_for_tick_begin {
2990 return unless $TICK_WATCHER->is_active;
2991 return if $Coro::current == $Coro::main;
2992
2993 my $signal = new Coro::Signal;
2994 push @WAIT_FOR_TICK_BEGIN, $signal;
2995 $signal->wait;
2996}
2997
2998 my $min = 1e6;#d#
2999 my $avg = 10;
2588$TICK_WATCHER = Event->timer ( 3000$TICK_WATCHER = Event->timer (
2589 reentrant => 0, 3001 reentrant => 0,
2590 parked => 1, 3002 parked => 1,
2591 prio => 0, 3003 prio => 0,
2592 at => $NEXT_TICK || $TICK, 3004 at => $NEXT_TICK || $TICK,
… …
2596 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3008 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2597 unless ++$bug_warning > 10; 3009 unless ++$bug_warning > 10;
2598 return; 3010 return;
2599 } 3011 }
2600 3012
2601 $NOW = Event::time; 3013 $NOW = $tick_start = Event::time;
2602 3014
2603 cf::server_tick; # one server iteration 3015 cf::server_tick; # one server iteration
3016
3017 0 && sync_job {#d#
3018 for(1..10) {
3019 my $t = Event::time;
3020 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3021 or die;
3022
3023 $map->width (50);
3024 $map->height (50);
3025 $map->alloc;
3026 $map->_load_objects ("/tmp/x.map", 1);
3027 my $t = Event::time - $t;
3028
3029 #next unless $t < 0.0013;#d#
3030 if ($t < $min) {
3031 $min = $t;
3032 }
3033 $avg = $avg * 0.99 + $t * 0.01;
3034 }
3035 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3036 exit 0;
3037 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3038 };
3039
2604 $RUNTIME += $TICK; 3040 $RUNTIME += $TICK;
2605 $NEXT_TICK += $TICK; 3041 $NEXT_TICK += $TICK;
2606 3042
2607 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3043 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2608 $NEXT_RUNTIME_WRITE = $NOW + 10; 3044 $NEXT_RUNTIME_WRITE = $NOW + 10;
… …
2610 write_runtime 3046 write_runtime
2611 or warn "ERROR: unable to write runtime file: $!"; 3047 or warn "ERROR: unable to write runtime file: $!";
2612 }; 3048 };
2613 } 3049 }
2614 3050
2615 $WAIT_FOR_TICK->broadcast;
2616 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2617
2618# my $AFTER = Event::time; 3051# my $AFTER = Event::time;
2619# warn $AFTER - $NOW;#d# 3052# warn $AFTER - $NOW;#d#
2620 3053
3054 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3055 $sig->send;
3056 }
3057 while (my $sig = shift @WAIT_FOR_TICK) {
3058 $sig->send;
3059 }
3060
3061 $NOW = Event::time;
3062
2621 # if we are delayed by four ticks or more, skip them all 3063 # if we are delayed by four ticks or more, skip them all
2622 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3064 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2623 3065
2624 $TICK_WATCHER->at ($NEXT_TICK); 3066 $TICK_WATCHER->at ($NEXT_TICK);
2625 $TICK_WATCHER->start; 3067 $TICK_WATCHER->start;
3068
3069 $LOAD = ($NOW - $tick_start) / $TICK;
3070 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3071
3072 _post_tick;
3073
3074
2626 }, 3075 },
2627); 3076);
2628 3077
2629{ 3078{
2630 BDB::max_poll_time $TICK * 0.1; 3079 BDB::max_poll_time $TICK * 0.1;
… …
2658 3107
2659 cf::sync_job { 3108 cf::sync_job {
2660 eval { 3109 eval {
2661 BDB::db_env_open 3110 BDB::db_env_open
2662 $DB_ENV, 3111 $DB_ENV,
2663 $BDB_ENV_DIR, 3112 $BDBDIR,
2664 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3113 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2665 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3114 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2666 0666; 3115 0666;
2667 3116
2668 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3117 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2669 3118
2670 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3119 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2671 $DB_ENV->set_lk_detect; 3120 $DB_ENV->set_lk_detect;
2672 }; 3121 };
2673 3122
… …
2689 prio => 6, 3138 prio => 6,
2690 cb => \&IO::AIO::poll_cb, 3139 cb => \&IO::AIO::poll_cb,
2691 ); 3140 );
2692} 3141}
2693 3142
3143my $_log_backtrace;
3144
3145sub _log_backtrace {
3146 my ($msg, @addr) = @_;
3147
3148 $msg =~ s/\n//;
3149
3150 # limit the # of concurrent backtraces
3151 if ($_log_backtrace < 2) {
3152 ++$_log_backtrace;
3153 async {
3154 my @bt = fork_call {
3155 @addr = map { sprintf "%x", $_ } @addr;
3156 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3157 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3158 or die "addr2line: $!";
3159
3160 my @funcs;
3161 my @res = <$fh>;
3162 chomp for @res;
3163 while (@res) {
3164 my ($func, $line) = splice @res, 0, 2, ();
3165 push @funcs, "[$func] $line";
3166 }
3167
3168 @funcs
3169 };
3170
3171 LOG llevInfo, "[ABT] $msg\n";
3172 LOG llevInfo, "[ABT] $_\n" for @bt;
3173 --$_log_backtrace;
3174 };
3175 } else {
3176 LOG llevInfo, "[ABT] $msg\n";
3177 LOG llevInfo, "[ABT] [suppressed]\n";
3178 }
3179}
3180
3181# load additional modules
3182use cf::pod;
3183
2694END { cf::emergency_save } 3184END { cf::emergency_save }
2695 3185
26961 31861
2697 3187

Diff Legend

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