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.237 by root, Fri Apr 13 05:08:51 2007 UTC vs.
Revision 1.295 by root, Wed Jul 4 05:08:15 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;
21use Coro::Storable; 23use Coro::Storable;
22 24
25use JSON::XS 1.4 ();
23use BDB (); 26use BDB ();
24use Data::Dumper; 27use Data::Dumper;
25use Digest::MD5; 28use Digest::MD5;
26use Fcntl; 29use Fcntl;
27use YAML::Syck (); 30use YAML::Syck ();
47our %COMMAND = (); 50our %COMMAND = ();
48our %COMMAND_TIME = (); 51our %COMMAND_TIME = ();
49 52
50our @EXTS = (); # list of extension package names 53our @EXTS = (); # list of extension package names
51our %EXTCMD = (); 54our %EXTCMD = ();
55our %EXTICMD = ();
52our %EXT_CORO = (); # coroutines bound to extensions 56our %EXT_CORO = (); # coroutines bound to extensions
53our %EXT_MAP = (); # pluggable maps 57our %EXT_MAP = (); # pluggable maps
54 58
55our $RELOAD; # number of reloads so far 59our $RELOAD; # number of reloads so far
56our @EVENT; 60our @EVENT;
57our $LIBDIR = datadir . "/ext";
58 61
59our $TICK = MAX_TIME * 1e-6; 62our $CONFDIR = confdir;
63our $DATADIR = datadir;
64our $LIBDIR = "$DATADIR/ext";
65our $PODDIR = "$DATADIR/pod";
66our $MAPDIR = "$DATADIR/" . mapdir;
67our $LOCALDIR = localdir;
68our $TMPDIR = "$LOCALDIR/" . tmpdir;
69our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
70our $PLAYERDIR = "$LOCALDIR/" . playerdir;
71our $RANDOMDIR = "$LOCALDIR/random";
72our $BDBDIR = "$LOCALDIR/db";
73
74our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
60our $TICK_WATCHER; 75our $TICK_WATCHER;
61our $AIO_POLL_WATCHER; 76our $AIO_POLL_WATCHER;
62our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 77our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
63our $NEXT_TICK; 78our $NEXT_TICK;
64our $NOW; 79our $NOW;
73our $RUNTIME; 88our $RUNTIME;
74 89
75our %PLAYER; # all users 90our %PLAYER; # all users
76our %MAP; # all maps 91our %MAP; # all maps
77our $LINK_MAP; # the special {link} map, which is always available 92our $LINK_MAP; # the special {link} map, which is always available
78our $RANDOM_MAPS = cf::localdir . "/random";
79our $BDB_ENV_DIR = cf::localdir . "/db";
80
81our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
82our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
83 93
84# used to convert map paths into valid unix filenames by replacing / by ∕ 94# used to convert map paths into valid unix filenames by replacing / by ∕
85our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 95our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
86 96
97our $LOAD; # a number between 0 (idle) and 1 (too many objects)
98our $LOADAVG; # same thing, but with alpha-smoothing
99our $tick_start; # for load detecting purposes
100
87binmode STDOUT; 101binmode STDOUT;
88binmode STDERR; 102binmode STDERR;
89 103
90# read virtual server time, if available 104# read virtual server time, if available
91unless ($RUNTIME || !-e cf::localdir . "/runtime") { 105unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
92 open my $fh, "<", cf::localdir . "/runtime" 106 open my $fh, "<", "$LOCALDIR/runtime"
93 or die "unable to read runtime file: $!"; 107 or die "unable to read runtime file: $!";
94 $RUNTIME = <$fh> + 0.; 108 $RUNTIME = <$fh> + 0.;
95} 109}
96 110
97mkdir cf::localdir; 111mkdir $_
98mkdir cf::localdir . "/" . cf::playerdir; 112 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
99mkdir cf::localdir . "/" . cf::tmpdir;
100mkdir cf::localdir . "/" . cf::uniquedir;
101mkdir $RANDOM_MAPS;
102mkdir $BDB_ENV_DIR;
103 113
104our $EMERGENCY_POSITION; 114our $EMERGENCY_POSITION;
105 115
106sub cf::map::normalise; 116sub cf::map::normalise;
107 117
118=item $cf::RUNTIME 128=item $cf::RUNTIME
119 129
120The time this server has run, starts at 0 and is increased by $cf::TICK on 130The time this server has run, starts at 0 and is increased by $cf::TICK on
121every server tick. 131every server tick.
122 132
123=item $cf::LIBDIR 133=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
134$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
135$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
124 136
125The perl library directory, where extensions and cf-specific modules can 137Various directories - "/etc", read-only install directory, perl-library
126be found. It will be added to C<@INC> automatically. 138directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
139unique-items directory, player file directory, random maps directory and
140database environment.
127 141
128=item $cf::NOW 142=item $cf::NOW
129 143
130The time of the last (current) server tick. 144The time of the last (current) server tick.
131 145
132=item $cf::TICK 146=item $cf::TICK
133 147
134The interval between server ticks, in seconds. 148The interval between server ticks, in seconds.
149
150=item $cf::LOADAVG
151
152The current CPU load on the server (alpha-smoothed), as a value between 0
153(none) and 1 (overloaded), indicating how much time is spent on processing
154objects per tick. Healthy values are < 0.5.
155
156=item $cf::LOAD
157
158The raw value load value from the last tick.
135 159
136=item %cf::CFG 160=item %cf::CFG
137 161
138Configuration for the server, loaded from C</etc/crossfire/config>, or 162Configuration for the server, loaded from C</etc/crossfire/config>, or
139from wherever your confdir points to. 163from wherever your confdir points to.
140 164
141=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 165=item cf::wait_for_tick, cf::wait_for_tick_begin
142 166
143These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 167These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
144or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 168returns directly I<after> the tick processing (and consequently, can only wake one process
145processing has been done. Call C<< ->wait >> on them to maximise the 169per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
146window of cpu time available, or simply to synchronise to the server tick.
147 170
148=back 171=back
149 172
150=cut 173=cut
151 174
152BEGIN { 175BEGIN {
153 *CORE::GLOBAL::warn = sub { 176 *CORE::GLOBAL::warn = sub {
154 my $msg = join "", @_; 177 my $msg = join "", @_;
155 utf8::encode $msg;
156 178
157 $msg .= "\n" 179 $msg .= "\n"
158 unless $msg =~ /\n$/; 180 unless $msg =~ /\n$/;
159 181
182 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
183
184 utf8::encode $msg;
160 LOG llevError, $msg; 185 LOG llevError, $msg;
161 }; 186 };
162} 187}
163 188
164@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 189@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
165@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 190@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
166@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 191@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
167@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 192@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
168@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 193@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
194@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
169@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 195@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
170 196
171# we bless all objects into (empty) derived classes to force a method lookup 197# we bless all objects into (empty) derived classes to force a method lookup
172# within the Safe compartment. 198# within the Safe compartment.
173for my $pkg (qw( 199for my $pkg (qw(
174 cf::global cf::attachable 200 cf::global cf::attachable
182} 208}
183 209
184$Event::DIED = sub { 210$Event::DIED = sub {
185 warn "error in event callback: @_"; 211 warn "error in event callback: @_";
186}; 212};
213
214#############################################################################
187 215
188=head2 UTILITY FUNCTIONS 216=head2 UTILITY FUNCTIONS
189 217
190=over 4 218=over 4
191 219
210 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 238 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
211 $d 239 $d
212 } || "[unable to dump $_[0]: '$@']"; 240 } || "[unable to dump $_[0]: '$@']";
213} 241}
214 242
215use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
216
217=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
218 244
219Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
220 246
221=item $json = cf::to_json $ref 247=item $json = cf::to_json $ref
222 248
223Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
250
251=cut
252
253our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
254
255sub to_json ($) { $json_coder->encode ($_[0]) }
256sub from_json ($) { $json_coder->decode ($_[0]) }
224 257
225=item cf::lock_wait $string 258=item cf::lock_wait $string
226 259
227Wait until the given lock is available. See cf::lock_acquire. 260Wait until the given lock is available. See cf::lock_acquire.
228 261
234returned. 267returned.
235 268
236Lock names should begin with a unique identifier (for example, cf::map::find 269Lock names should begin with a unique identifier (for example, cf::map::find
237uses map_find and cf::map::load uses map_load). 270uses map_find and cf::map::load uses map_load).
238 271
272=item $locked = cf::lock_active $string
273
274Return true if the lock is currently active, i.e. somebody has locked it.
275
239=cut 276=cut
240 277
241our %LOCK; 278our %LOCK;
242 279
243sub lock_wait($) { 280sub lock_wait($) {
260 297
261 Coro::guard { 298 Coro::guard {
262 # wake up all waiters, to be on the safe side 299 # wake up all waiters, to be on the safe side
263 $_->ready for @{ delete $LOCK{$key} }; 300 $_->ready for @{ delete $LOCK{$key} };
264 } 301 }
302}
303
304sub lock_active($) {
305 my ($key) = @_;
306
307 ! ! $LOCK{$key}
265} 308}
266 309
267sub freeze_mainloop { 310sub freeze_mainloop {
268 return unless $TICK_WATCHER->is_active; 311 return unless $TICK_WATCHER->is_active;
269 312
284 327
285BEGIN { *async = \&Coro::async_pool } 328BEGIN { *async = \&Coro::async_pool }
286 329
287=item cf::sync_job { BLOCK } 330=item cf::sync_job { BLOCK }
288 331
289The design of crossfire+ requires that the main coro ($Coro::main) is 332The design of Crossfire TRT requires that the main coroutine ($Coro::main)
290always able to handle events or runnable, as crossfire+ is only partly 333is always able to handle events or runnable, as Crossfire TRT is only
291reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 334partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
335acceptable.
292 336
293If it must be done, put the blocking parts into C<sync_job>. This will run 337If it must be done, put the blocking parts into C<sync_job>. This will run
294the given BLOCK in another coroutine while waiting for the result. The 338the given BLOCK in another coroutine while waiting for the result. The
295server will be frozen during this time, so the block should either finish 339server will be frozen during this time, so the block should either finish
296fast or be very important. 340fast or be very important.
299 343
300sub sync_job(&) { 344sub sync_job(&) {
301 my ($job) = @_; 345 my ($job) = @_;
302 346
303 if ($Coro::current == $Coro::main) { 347 if ($Coro::current == $Coro::main) {
348 my $time = Event::time;
349
304 # this is the main coro, too bad, we have to block 350 # this is the main coro, too bad, we have to block
305 # till the operation succeeds, freezing the server :/ 351 # till the operation succeeds, freezing the server :/
306 352
307 # TODO: use suspend/resume instead 353 # TODO: use suspend/resume instead
308 # (but this is cancel-safe) 354 # (but this is cancel-safe)
319 365
320 while ($busy) { 366 while ($busy) {
321 Coro::cede or Event::one_event; 367 Coro::cede or Event::one_event;
322 } 368 }
323 369
370 $time = Event::time - $time;
371
372 LOG llevError | logBacktrace, Carp::longmess "long sync job"
373 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
374
375 $tick_start += $time; # do not account sync jobs to server load
376
324 wantarray ? @res : $res[0] 377 wantarray ? @res : $res[0]
325 } else { 378 } else {
326 # we are in another coroutine, how wonderful, everything just works 379 # we are in another coroutine, how wonderful, everything just works
327 380
328 $job->() 381 $job->()
347 $EXT_CORO{$coro+0} = $coro; 400 $EXT_CORO{$coro+0} = $coro;
348 401
349 $coro 402 $coro
350} 403}
351 404
352sub write_runtime { 405=item fork_call { }, $args
353 my $guard = cf::lock_acquire "write_runtime";
354 406
355 my $runtime = cf::localdir . "/runtime"; 407Executes the given code block with the given arguments in a seperate
408process, returning the results. Everything must be serialisable with
409Coro::Storable. May, of course, block. Note that the executed sub may
410never block itself or use any form of Event handling.
356 411
357 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 412=cut
358 or return;
359 413
360 my $value = $cf::RUNTIME + 90 + 10; 414sub fork_call(&@) {
361 # 10 is the runtime save interval, for a monotonic clock 415 my ($cb, @args) = @_;
362 # 60 allows for the watchdog to kill the server.
363 416
364 (aio_write $fh, 0, (length $value), $value, 0) <= 0 417# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
365 and return; 418# or die "socketpair: $!";
419 pipe my $fh1, my $fh2
420 or die "pipe: $!";
366 421
367 # always fsync - this file is important 422 if (my $pid = fork) {
368 aio_fsync $fh
369 and return;
370
371 close $fh 423 close $fh2;
372 or return;
373 424
374 aio_rename "$runtime~", $runtime 425 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
375 and return; 426 $res = Coro::Storable::thaw $res;
376 427
428 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
429
430 die $$res unless "ARRAY" eq ref $res;
431
432 return wantarray ? @$res : $res->[-1];
433 } else {
434 reset_signals;
435 local $SIG{__WARN__};
436 local $SIG{__DIE__};
437 eval {
438 close $fh1;
439
440 my @res = eval { $cb->(@args) };
441 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
442 };
443
444 warn $@ if $@;
445 _exit 0;
377 1 446 }
447}
448
449=item $value = cf::db_get $family => $key
450
451Returns a single value from the environment database.
452
453=item cf::db_put $family => $key => $value
454
455Stores the given C<$value> in the family. It can currently store binary
456data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
457
458=cut
459
460our $DB;
461
462sub db_init {
463 unless ($DB) {
464 $DB = BDB::db_create $DB_ENV;
465
466 cf::sync_job {
467 eval {
468 $DB->set_flags (BDB::CHKSUM);
469
470 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
471 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
472 cf::cleanup "db_open(db): $!" if $!;
473 };
474 cf::cleanup "db_open(db): $@" if $@;
475 };
476 }
477}
478
479sub db_get($$) {
480 my $key = "$_[0]/$_[1]";
481
482 cf::sync_job {
483 BDB::db_get $DB, undef, $key, my $data;
484
485 $! ? ()
486 : $data
487 }
488}
489
490sub db_put($$$) {
491 BDB::dbreq_pri 4;
492 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
493}
494
495=item cf::cache $id => [$paths...], $processversion => $process
496
497Generic caching function that returns the value of the resource $id,
498caching and regenerating as required.
499
500This function can block.
501
502=cut
503
504sub cache {
505 my ($id, $src, $processversion, $process) = @_;
506
507 my $meta =
508 join "\x00",
509 $processversion,
510 map {
511 aio_stat $_
512 and Carp::croak "$_: $!";
513
514 ($_, (stat _)[7,9])
515 } @$src;
516
517 my $dbmeta = db_get cache => "$id/meta";
518 if ($dbmeta ne $meta) {
519 # changed, we may need to process
520
521 my @data;
522 my $md5;
523
524 for (0 .. $#$src) {
525 0 <= aio_load $src->[$_], $data[$_]
526 or Carp::croak "$src->[$_]: $!";
527 }
528
529 # if processing is expensive, check
530 # checksum first
531 if (1) {
532 $md5 =
533 join "\x00",
534 $processversion,
535 map {
536 Coro::cede;
537 ($src->[$_], Digest::MD5::md5_hex $data[$_])
538 } 0.. $#$src;
539
540
541 my $dbmd5 = db_get cache => "$id/md5";
542 if ($dbmd5 eq $md5) {
543 db_put cache => "$id/meta", $meta;
544
545 return db_get cache => "$id/data";
546 }
547 }
548
549 my $t1 = Time::HiRes::time;
550 my $data = $process->(\@data);
551 my $t2 = Time::HiRes::time;
552
553 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
554
555 db_put cache => "$id/data", $data;
556 db_put cache => "$id/md5" , $md5;
557 db_put cache => "$id/meta", $meta;
558
559 return $data;
560 }
561
562 db_get cache => "$id/data"
378} 563}
379 564
380=item cf::datalog type => key => value, ... 565=item cf::datalog type => key => value, ...
381 566
382Log a datalog packet of the given type with the given key-value pairs. 567Log a datalog packet of the given type with the given key-value pairs.
400attach callbacks/event handlers (a collection of which is called an "attachment") 585attach callbacks/event handlers (a collection of which is called an "attachment")
401to it. All such attachable objects support the following methods. 586to it. All such attachable objects support the following methods.
402 587
403In the following description, CLASS can be any of C<global>, C<object> 588In the following description, CLASS can be any of C<global>, C<object>
404C<player>, C<client> or C<map> (i.e. the attachable objects in 589C<player>, C<client> or C<map> (i.e. the attachable objects in
405crossfire+). 590Crossfire TRT).
406 591
407=over 4 592=over 4
408 593
409=item $attachable->attach ($attachment, key => $value...) 594=item $attachable->attach ($attachment, key => $value...)
410 595
573 $registry = $CB_TYPE[$object_type] ||= []; 758 $registry = $CB_TYPE[$object_type] ||= [];
574 759
575 } elsif ($type eq "subtype") { 760 } elsif ($type eq "subtype") {
576 defined $object_type or Carp::croak "subtype specified without type"; 761 defined $object_type or Carp::croak "subtype specified without type";
577 my $object_subtype = shift @arg; 762 my $object_subtype = shift @arg;
578 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 763 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
579 764
580 } elsif ($type eq "package") { 765 } elsif ($type eq "package") {
581 my $pkg = shift @arg; 766 my $pkg = shift @arg;
582 767
583 while (my ($name, $id) = each %cb_id) { 768 while (my ($name, $id) = each %cb_id) {
612 _attach $registry, $klass, @attach; 797 _attach $registry, $klass, @attach;
613 } 798 }
614 799
615 $obj->{$name} = \%arg; 800 $obj->{$name} = \%arg;
616 } else { 801 } else {
617 warn "object uses attachment '$name' that is not available, postponing.\n"; 802 warn "object uses attachment '$name' which is not available, postponing.\n";
618 } 803 }
619 804
620 $obj->{_attachment}{$name} = undef; 805 $obj->{_attachment}{$name} = undef;
621} 806}
622 807
624 if (ref $_[0]) { 809 if (ref $_[0]) {
625 _object_attach @_; 810 _object_attach @_;
626 } else { 811 } else {
627 _attach shift->_attach_registry, @_; 812 _attach shift->_attach_registry, @_;
628 } 813 }
814 _recalc_want;
629}; 815};
630 816
631# all those should be optimised 817# all those should be optimised
632sub cf::attachable::detach { 818sub cf::attachable::detach {
633 my ($obj, $name) = @_; 819 my ($obj, $name) = @_;
636 delete $obj->{_attachment}{$name}; 822 delete $obj->{_attachment}{$name};
637 reattach ($obj); 823 reattach ($obj);
638 } else { 824 } else {
639 Carp::croak "cannot, currently, detach class attachments"; 825 Carp::croak "cannot, currently, detach class attachments";
640 } 826 }
827 _recalc_want;
641}; 828};
642 829
643sub cf::attachable::attached { 830sub cf::attachable::attached {
644 my ($obj, $name) = @_; 831 my ($obj, $name) = @_;
645 832
818 or return; 1005 or return;
819 $av = eval { (Storable::thaw $av)->{objs} }; 1006 $av = eval { (Storable::thaw $av)->{objs} };
820 } 1007 }
821 1008
822 warn sprintf "loading %s (%d)\n", 1009 warn sprintf "loading %s (%d)\n",
823 $filename, length $data, scalar @{$av || []};#d# 1010 $filename, length $data, scalar @{$av || []};
824 return ($data, $av); 1011 return ($data, $av);
825} 1012}
1013
1014=head2 COMMAND CALLBACKS
1015
1016=over 4
1017
1018=cut
826 1019
827############################################################################# 1020#############################################################################
828# command handling &c 1021# command handling &c
829 1022
830=item cf::register_command $name => \&callback($ob,$args); 1023=item cf::register_command $name => \&callback($ob,$args);
843 push @{ $COMMAND{$name} }, [$caller, $cb]; 1036 push @{ $COMMAND{$name} }, [$caller, $cb];
844} 1037}
845 1038
846=item cf::register_extcmd $name => \&callback($pl,$packet); 1039=item cf::register_extcmd $name => \&callback($pl,$packet);
847 1040
848Register a callbackf ro execution when the client sends an extcmd packet. 1041Register a callback for execution when the client sends an (synchronous)
1042extcmd packet. Ext commands will be processed in the order they are
1043received by the server, like other user commands. The first argument is
1044the logged-in player. Ext commands can only be processed after a player
1045has logged in successfully.
849 1046
850If the callback returns something, it is sent back as if reply was being 1047If the callback returns something, it is sent back as if reply was being
851called. 1048called.
852 1049
1050=item cf::register_exticmd $name => \&callback($ns,$packet);
1051
1052Register a callback for execution when the client sends an (asynchronous)
1053exticmd packet. Exti commands are processed by the server as soon as they
1054are received, i.e. out of order w.r.t. other commands. The first argument
1055is a client socket. Exti commands can be received anytime, even before
1056log-in.
1057
1058If the callback returns something, it is sent back as if reply was being
1059called.
1060
853=cut 1061=cut
854 1062
855sub register_extcmd { 1063sub register_extcmd {
856 my ($name, $cb) = @_; 1064 my ($name, $cb) = @_;
857 1065
858 $EXTCMD{$name} = $cb; 1066 $EXTCMD{$name} = $cb;
1067}
1068
1069sub register_exticmd {
1070 my ($name, $cb) = @_;
1071
1072 $EXTICMD{$name} = $cb;
859} 1073}
860 1074
861cf::player->attach ( 1075cf::player->attach (
862 on_command => sub { 1076 on_command => sub {
863 my ($pl, $name, $params) = @_; 1077 my ($pl, $name, $params) = @_;
872 cf::override; 1086 cf::override;
873 }, 1087 },
874 on_extcmd => sub { 1088 on_extcmd => sub {
875 my ($pl, $buf) = @_; 1089 my ($pl, $buf) = @_;
876 1090
877 my $msg = eval { from_json $buf }; 1091 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
878 1092
879 if (ref $msg) { 1093 if (ref $msg) {
880 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1094 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
881 if (my %reply = $cb->($pl, $msg)) { 1095 if (my %reply = $cb->($pl, $msg)) {
882 $pl->ext_reply ($msg->{msgid}, %reply); 1096 $pl->ext_reply ($msg->{msgid}, %reply);
888 1102
889 cf::override; 1103 cf::override;
890 }, 1104 },
891); 1105);
892 1106
893sub load_extension {
894 my ($path) = @_;
895
896 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
897 my $base = $1;
898 my $pkg = $1;
899 $pkg =~ s/[^[:word:]]/_/g;
900 $pkg = "ext::$pkg";
901
902 warn "... loading '$path' into '$pkg'\n";
903
904 open my $fh, "<:utf8", $path
905 or die "$path: $!";
906
907 my $source =
908 "package $pkg; use strict; use utf8;\n"
909 . "#line 1 \"$path\"\n{\n"
910 . (do { local $/; <$fh> })
911 . "\n};\n1";
912
913 unless (eval $source) {
914 my $msg = $@ ? "$path: $@\n"
915 : "extension disabled.\n";
916 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
917 warn $@;
918 warn "mandatory extension failed to load, exiting.\n";
919 exit 1;
920 }
921 die $@;
922 }
923
924 push @EXTS, $pkg;
925}
926
927sub load_extensions { 1107sub load_extensions {
1108 cf::sync_job {
1109 my %todo;
1110
928 for my $ext (<$LIBDIR/*.ext>) { 1111 for my $path (<$LIBDIR/*.ext>) {
929 next unless -r $ext; 1112 next unless -r $path;
930 eval { 1113
931 load_extension $ext; 1114 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1115 my $base = $1;
1116 my $pkg = $1;
1117 $pkg =~ s/[^[:word:]]/_/g;
1118 $pkg = "ext::$pkg";
1119
1120 open my $fh, "<:utf8", $path
1121 or die "$path: $!";
1122
1123 my $source = do { local $/; <$fh> };
1124
1125 my %ext = (
1126 path => $path,
1127 base => $base,
1128 pkg => $pkg,
1129 );
1130
1131 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1132 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1133
1134 $ext{source} =
1135 "package $pkg; use strict; use utf8;\n"
1136 . "#line 1 \"$path\"\n{\n"
1137 . $source
1138 . "\n};\n1";
1139
1140 $todo{$base} = \%ext;
1141 }
1142
1143 my %done;
1144 while (%todo) {
1145 my $progress;
1146
1147 while (my ($k, $v) = each %todo) {
1148 for (split /,\s*/, $v->{meta}{depends}) {
1149 goto skip
1150 unless exists $done{$_};
1151 }
1152
1153 warn "... loading '$k' into '$v->{pkg}'\n";
1154
1155 unless (eval $v->{source}) {
1156 my $msg = $@ ? "$v->{path}: $@\n"
1157 : "$v->{base}: extension inactive.\n";
1158
1159 if (exists $v->{meta}{mandatory}) {
1160 warn $msg;
1161 warn "mandatory extension failed to load, exiting.\n";
1162 exit 1;
1163 }
1164
1165 warn $msg;
1166 }
1167
1168 $done{$k} = delete $todo{$k};
1169 push @EXTS, $v->{pkg};
1170 $progress = 1;
932 1 1171 }
933 } or warn "$ext not loaded: $@"; 1172
1173 skip:
1174 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1175 unless $progress;
1176 }
934 } 1177 };
935} 1178}
936 1179
937############################################################################# 1180#############################################################################
938 1181
1182=back
1183
939=head2 CORE EXTENSIONS 1184=head2 CORE EXTENSIONS
940 1185
941Functions and methods that extend core crossfire objects. 1186Functions and methods that extend core crossfire objects.
942 1187
943=cut 1188=cut
955Returns the given player object, loading it if necessary (might block). 1200Returns the given player object, loading it if necessary (might block).
956 1201
957=cut 1202=cut
958 1203
959sub playerdir($) { 1204sub playerdir($) {
960 cf::localdir 1205 "$PLAYERDIR/"
961 . "/"
962 . cf::playerdir
963 . "/"
964 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1206 . (ref $_[0] ? $_[0]->ob->name : $_[0])
965} 1207}
966 1208
967sub path($) { 1209sub path($) {
968 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1210 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1088while and may block, so not sync_job-capable, ever. 1330while and may block, so not sync_job-capable, ever.
1089 1331
1090=cut 1332=cut
1091 1333
1092sub list_logins { 1334sub list_logins {
1093 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1335 my $dirs = aio_readdir $PLAYERDIR
1094 or return []; 1336 or return [];
1095 1337
1096 my @logins; 1338 my @logins;
1097 1339
1098 for my $login (@$dirs) { 1340 for my $login (@$dirs) {
1133 } 1375 }
1134 1376
1135 \@paths 1377 \@paths
1136} 1378}
1137 1379
1380=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1381
1382Expand crossfire pod fragments into protocol xml.
1383
1384=cut
1385
1386sub expand_cfpod {
1387 ((my $self), (local $_)) = @_;
1388
1389 # escape & and <
1390 s/&/&amp;/g;
1391 s/(?<![BIUGH])</&lt;/g;
1392
1393 # this is buggy, it needs to properly take care of nested <'s
1394
1395 1 while
1396 # replace B<>, I<>, U<> etc.
1397 s/B<([^\>]*)>/<b>$1<\/b>/
1398 || s/I<([^\>]*)>/<i>$1<\/i>/
1399 || s/U<([^\>]*)>/<u>$1<\/u>/
1400 # replace G<male|female> tags
1401 || s{G<([^>|]*)\|([^>]*)>}{
1402 $self->gender ? $2 : $1
1403 }ge
1404 # replace H<hint text>
1405 || s{H<([^\>]*)>}
1406 {
1407 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1408 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1409 "")
1410 [$self->{hintmode}]
1411 }ge;
1412
1413 # create single paragraphs (very hackish)
1414 s/(?<=\S)\n(?=\w)/ /g;
1415
1416 # compress some whitespace
1417 s/\s+\n/\n/g; # ws line-ends
1418 s/\n\n+/\n/g; # double lines
1419 s/^\n+//; # beginning lines
1420 s/\n+$//; # ending lines
1421
1422 $_
1423}
1424
1425sub hintmode {
1426 $_[0]{hintmode} = $_[1] if @_ > 1;
1427 $_[0]{hintmode}
1428}
1429
1138=item $player->ext_reply ($msgid, %msg) 1430=item $player->ext_reply ($msgid, %msg)
1139 1431
1140Sends an ext reply to the player. 1432Sends an ext reply to the player.
1141 1433
1142=cut 1434=cut
1143 1435
1144sub ext_reply($$%) { 1436sub ext_reply($$%) {
1145 my ($self, $id, %msg) = @_; 1437 my ($self, $id, %msg) = @_;
1146 1438
1147 $msg{msgid} = $id; 1439 $msg{msgid} = $id;
1148 1440 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1149 $self->send ("ext " . cf::to_json \%msg);
1150} 1441}
1151 1442
1152=item $player->ext_event ($type, %msg) 1443=item $player->ext_event ($type, %msg)
1153 1444
1154Sends an ext event to the client. 1445Sends an ext event to the client.
1159 my ($self, $type, %msg) = @_; 1450 my ($self, $type, %msg) = @_;
1160 1451
1161 $self->ns->ext_event ($type, %msg); 1452 $self->ns->ext_event ($type, %msg);
1162} 1453}
1163 1454
1164package cf; 1455=head3 cf::region
1456
1457=over 4
1458
1459=cut
1460
1461package cf::region;
1462
1463=item cf::region::find_by_path $path
1464
1465Tries to decuce the likely region for a map knowing only its path.
1466
1467=cut
1468
1469sub find_by_path($) {
1470 my ($path) = @_;
1471
1472 my ($match, $specificity);
1473
1474 for my $region (list) {
1475 if ($region->match && $path =~ $region->match) {
1476 ($match, $specificity) = ($region, $region->specificity)
1477 if $region->specificity > $specificity;
1478 }
1479 }
1480
1481 $match
1482}
1165 1483
1166=back 1484=back
1167
1168 1485
1169=head3 cf::map 1486=head3 cf::map
1170 1487
1171=over 4 1488=over 4
1172 1489
1227 my ($self, $merge) = @_; 1544 my ($self, $merge) = @_;
1228 1545
1229 # we have to keep some variables in memory intact 1546 # we have to keep some variables in memory intact
1230 local $self->{path}; 1547 local $self->{path};
1231 local $self->{load_path}; 1548 local $self->{load_path};
1232 local $self->{deny_save};
1233 local $self->{deny_reset};
1234 1549
1235 $self->SUPER::thawer_merge ($merge); 1550 $self->SUPER::thawer_merge ($merge);
1236} 1551}
1237 1552
1238sub normalise { 1553sub normalise {
1310 1625
1311# the original (read-only) location 1626# the original (read-only) location
1312sub load_path { 1627sub load_path {
1313 my ($self) = @_; 1628 my ($self) = @_;
1314 1629
1315 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1630 "$MAPDIR/$self->{path}.map"
1316} 1631}
1317 1632
1318# the temporary/swap location 1633# the temporary/swap location
1319sub save_path { 1634sub save_path {
1320 my ($self) = @_; 1635 my ($self) = @_;
1321 1636
1322 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1637 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1323 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1638 "$TMPDIR/$path.map"
1324} 1639}
1325 1640
1326# the unique path, undef == no special unique path 1641# the unique path, undef == no special unique path
1327sub uniq_path { 1642sub uniq_path {
1328 my ($self) = @_; 1643 my ($self) = @_;
1329 1644
1330 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1645 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1331 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1646 "$UNIQUEDIR/$path"
1332} 1647}
1333 1648
1334# and all this just because we cannot iterate over 1649# and all this just because we cannot iterate over
1335# all maps in C++... 1650# all maps in C++...
1336sub change_all_map_light { 1651sub change_all_map_light {
1337 my ($change) = @_; 1652 my ($change) = @_;
1338 1653
1339 $_->change_map_light ($change) 1654 $_->change_map_light ($change)
1340 for grep $_->outdoor, values %cf::MAP; 1655 for grep $_->outdoor, values %cf::MAP;
1656}
1657
1658sub decay_objects {
1659 my ($self) = @_;
1660
1661 return if $self->{deny_reset};
1662
1663 $self->do_decay_objects;
1341} 1664}
1342 1665
1343sub unlink_save { 1666sub unlink_save {
1344 my ($self) = @_; 1667 my ($self) = @_;
1345 1668
1403 $self->load_header_orig 1726 $self->load_header_orig
1404 or return; 1727 or return;
1405 $self->prepare_orig; 1728 $self->prepare_orig;
1406 } 1729 }
1407 1730
1731 $self->{deny_reset} = 1
1732 if $self->no_reset;
1733
1734 $self->default_region (cf::region::find_by_path $self->{path})
1735 unless $self->default_region;
1736
1408 1 1737 1
1409} 1738}
1410 1739
1411sub find; 1740sub find;
1412sub find { 1741sub find {
1424 $map->{last_save} = $cf::RUNTIME; 1753 $map->{last_save} = $cf::RUNTIME;
1425 1754
1426 $map->load_header 1755 $map->load_header
1427 or return; 1756 or return;
1428 1757
1429 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1758 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1430 # doing this can freeze the server in a sync job, obviously 1759 # doing this can freeze the server in a sync job, obviously
1431 #$cf::WAIT_FOR_TICK->wait; 1760 #$cf::WAIT_FOR_TICK->wait;
1432 $map->reset; 1761 $map->reset;
1433 undef $guard; 1762 undef $guard;
1434 return find $path; 1763 return find $path;
1445 my ($self) = @_; 1774 my ($self) = @_;
1446 1775
1447 local $self->{deny_reset} = 1; # loading can take a long time 1776 local $self->{deny_reset} = 1; # loading can take a long time
1448 1777
1449 my $path = $self->{path}; 1778 my $path = $self->{path};
1779
1780 {
1450 my $guard = cf::lock_acquire "map_load:$path"; 1781 my $guard = cf::lock_acquire "map_load:$path";
1451 1782
1452 return if $self->in_memory != cf::MAP_SWAPPED; 1783 return if $self->in_memory != cf::MAP_SWAPPED;
1453 1784
1454 $self->in_memory (cf::MAP_LOADING); 1785 $self->in_memory (cf::MAP_LOADING);
1455 1786
1456 $self->alloc; 1787 $self->alloc;
1457 1788
1458 $self->pre_load; 1789 $self->pre_load;
1459
1460 $self->_load_objects ($self->{load_path}, 1)
1461 or return;
1462
1463 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1464 if delete $self->{load_original};
1465
1466 if (my $uniq = $self->uniq_path) {
1467 utf8::encode $uniq;
1468 if (aio_open $uniq, O_RDONLY, 0) {
1469 $self->clear_unique_items;
1470 $self->_load_objects ($uniq, 0);
1471 }
1472 }
1473
1474 Coro::cede;
1475
1476 # now do the right thing for maps
1477 $self->link_multipart_objects;
1478
1479 unless ($self->{deny_activate}) {
1480 $self->decay_objects;
1481 $self->fix_auto_apply;
1482 $self->update_buttons;
1483 Coro::cede; 1790 Coro::cede;
1484 $self->set_darkness_map; 1791
1792 $self->_load_objects ($self->{load_path}, 1)
1793 or return;
1794
1795 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1796 if delete $self->{load_original};
1797
1798 if (my $uniq = $self->uniq_path) {
1799 utf8::encode $uniq;
1800 if (aio_open $uniq, O_RDONLY, 0) {
1801 $self->clear_unique_items;
1802 $self->_load_objects ($uniq, 0);
1803 }
1804 }
1805
1806 Coro::cede;
1807 # now do the right thing for maps
1808 $self->link_multipart_objects;
1485 $self->difficulty ($self->estimate_difficulty) 1809 $self->difficulty ($self->estimate_difficulty)
1486 unless $self->difficulty; 1810 unless $self->difficulty;
1487 Coro::cede; 1811 Coro::cede;
1812
1813 unless ($self->{deny_activate}) {
1814 $self->decay_objects;
1815 $self->fix_auto_apply;
1816 $self->update_buttons;
1817 Coro::cede;
1818 $self->set_darkness_map;
1819 Coro::cede;
1488 $self->activate; 1820 $self->activate;
1821 }
1822
1823 $self->in_memory (cf::MAP_IN_MEMORY);
1489 } 1824 }
1490 1825
1491 $self->post_load; 1826 $self->post_load;
1492
1493 $self->in_memory (cf::MAP_IN_MEMORY);
1494} 1827}
1495 1828
1496sub customise_for { 1829sub customise_for {
1497 my ($self, $ob) = @_; 1830 my ($self, $ob) = @_;
1498 1831
1499 return find "~" . $ob->name . "/" . $self->{path} 1832 return find "~" . $ob->name . "/" . $self->{path}
1500 if $self->per_player; 1833 if $self->per_player;
1834
1835# return find "?party/" . $ob->name . "/" . $self->{path}
1836# if $self->per_party;
1501 1837
1502 $self 1838 $self
1503} 1839}
1504 1840
1505# find and load all maps in the 3x3 area around a map 1841# find and load all maps in the 3x3 area around a map
1616 1952
1617sub reset_at { 1953sub reset_at {
1618 my ($self) = @_; 1954 my ($self) = @_;
1619 1955
1620 # TODO: safety, remove and allow resettable per-player maps 1956 # TODO: safety, remove and allow resettable per-player maps
1621 return 1e99 if $self->isa ("ext::map_per_player");#d#
1622 return 1e99 if $self->{deny_reset}; 1957 return 1e99 if $self->{deny_reset};
1623 1958
1624 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1959 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1625 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1960 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1626 1961
1637 my ($self) = @_; 1972 my ($self) = @_;
1638 1973
1639 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1974 my $lock = cf::lock_acquire "map_data:$self->{path}";
1640 1975
1641 return if $self->players; 1976 return if $self->players;
1642 return if $self->isa ("ext::map_per_player");#d#
1643 1977
1644 warn "resetting map ", $self->path;#d# 1978 warn "resetting map ", $self->path;
1645 1979
1646 $self->in_memory (cf::MAP_SWAPPED); 1980 $self->in_memory (cf::MAP_SWAPPED);
1647 1981
1648 # need to save uniques path 1982 # need to save uniques path
1649 unless ($self->{deny_save}) { 1983 unless ($self->{deny_save}) {
1681 $cf::MAP{$self->path} = $self; 2015 $cf::MAP{$self->path} = $self;
1682 2016
1683 $self->reset; # polite request, might not happen 2017 $self->reset; # polite request, might not happen
1684} 2018}
1685 2019
2020=item $maps = cf::map::tmp_maps
2021
2022Returns an arrayref with all map paths of currently instantiated and saved
2023maps. May block.
2024
2025=cut
2026
2027sub tmp_maps() {
2028 [
2029 map {
2030 utf8::decode $_;
2031 /\.map$/
2032 ? normalise $_
2033 : ()
2034 } @{ aio_readdir $TMPDIR or [] }
2035 ]
2036}
2037
2038=item $maps = cf::map::random_maps
2039
2040Returns an arrayref with all map paths of currently instantiated and saved
2041random maps. May block.
2042
2043=cut
2044
2045sub random_maps() {
2046 [
2047 map {
2048 utf8::decode $_;
2049 /\.map$/
2050 ? normalise "?random/$_"
2051 : ()
2052 } @{ aio_readdir $RANDOMDIR or [] }
2053 ]
2054}
2055
1686=item cf::map::unique_maps 2056=item cf::map::unique_maps
1687 2057
1688Returns an arrayref of paths of all shared maps that have 2058Returns an arrayref of paths of all shared maps that have
1689instantiated unique items. May block. 2059instantiated unique items. May block.
1690 2060
1691=cut 2061=cut
1692 2062
1693sub unique_maps() { 2063sub unique_maps() {
1694 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 2064 [
1695 or return; 2065 map {
1696
1697 my @paths;
1698
1699 for (@$files) {
1700 utf8::decode $_; 2066 utf8::decode $_;
1701 next if /\.pst$/; 2067 /\.map$/
1702 next unless /^$PATH_SEP/o; 2068 ? normalise $_
1703 2069 : ()
1704 push @paths, cf::map::normalise $_; 2070 } @{ aio_readdir $UNIQUEDIR or [] }
1705 } 2071 ]
1706
1707 \@paths
1708} 2072}
1709 2073
1710package cf; 2074package cf;
1711 2075
1712=back 2076=back
1758 2122
1759 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2123 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1760 2124
1761 if ($self->{record_replies}) { 2125 if ($self->{record_replies}) {
1762 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2126 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2127
1763 } else { 2128 } else {
2129 my $pl = $self->contr;
2130
2131 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2132 my $diag = $pl->{npc_dialog};
2133 $diag->{pl}->ext_reply (
2134 $diag->{id},
2135 msgtype => "reply",
2136 msg => $diag->{pl}->expand_cfpod ($msg),
2137 add_topics => []
2138 );
2139
2140 } else {
1764 $msg = $npc->name . " says: $msg" if $npc; 2141 $msg = $npc->name . " says: $msg" if $npc;
1765 $self->message ($msg, $flags); 2142 $self->message ($msg, $flags);
2143 }
1766 } 2144 }
1767} 2145}
1768 2146
1769=item $player_object->may ("access") 2147=item $player_object->may ("access")
1770 2148
1818 $self->deactivate_recursive; 2196 $self->deactivate_recursive;
1819 2197
1820 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2198 return if UNIVERSAL::isa $self->map, "ext::map_link";
1821 2199
1822 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2200 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1823 if $self->map; 2201 if $self->map && $self->map->{path} ne "{link}";
1824 2202
1825 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2203 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1826} 2204}
1827 2205
1828sub cf::object::player::leave_link { 2206sub cf::object::player::leave_link {
1829 my ($self, $map, $x, $y) = @_; 2207 my ($self, $map, $x, $y) = @_;
2208
2209 return unless $self->contr->active;
1830 2210
1831 my $link_pos = delete $self->{_link_pos}; 2211 my $link_pos = delete $self->{_link_pos};
1832 2212
1833 unless ($map) { 2213 unless ($map) {
1834 # restore original map position 2214 # restore original map position
1857 2237
1858 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2238 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1859 $self->enter_map ($map, $x, $y); 2239 $self->enter_map ($map, $x, $y);
1860} 2240}
1861 2241
1862cf::player->attach (
1863 on_logout => sub {
1864 my ($pl) = @_;
1865
1866 # abort map switching before logout
1867 if ($pl->ob->{_link_pos}) {
1868 cf::sync_job {
1869 $pl->ob->leave_link
1870 };
1871 }
1872 },
1873 on_login => sub {
1874 my ($pl) = @_;
1875
1876 # try to abort aborted map switching on player login :)
1877 # should happen only on crashes
1878 if ($pl->ob->{_link_pos}) {
1879 $pl->ob->enter_link;
1880 (async {
1881 $pl->ob->reply (undef,
1882 "There was an internal problem at your last logout, "
1883 . "the server will try to bring you to your intended destination in a second.",
1884 cf::NDI_RED);
1885 # we need this sleep as the login has a concurrent enter_exit running
1886 # and this sleep increases chances of the player not ending up in scorn
1887 Coro::Timer::sleep 1;
1888 $pl->ob->leave_link;
1889 })->prio (2);
1890 }
1891 },
1892);
1893
1894=item $player_object->goto ($path, $x, $y) 2242=item $player_object->goto ($path, $x, $y[, $check->($map)])
1895 2243
2244Moves the player to the given map-path and coordinates by first freezing
2245her, loading and preparing them map, calling the provided $check callback
2246that has to return the map if sucecssful, and then unfreezes the player on
2247the new (success) or old (failed) map position.
2248
1896=cut 2249=cut
2250
2251our $GOTOGEN;
1897 2252
1898sub cf::object::player::goto { 2253sub cf::object::player::goto {
1899 my ($self, $path, $x, $y) = @_; 2254 my ($self, $path, $x, $y, $check) = @_;
2255
2256 # do generation counting so two concurrent goto's will be executed in-order
2257 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1900 2258
1901 $self->enter_link; 2259 $self->enter_link;
1902 2260
1903 (async { 2261 (async {
1904 my $map = eval { 2262 my $map = eval {
1905 my $map = cf::map::find $path; 2263 my $map = cf::map::find $path;
2264
2265 if ($map) {
1906 $map = $map->customise_for ($self) if $map; 2266 $map = $map->customise_for ($self);
2267 $map = $check->($map) if $check && $map;
2268 } else {
2269 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2270 }
2271
1907 $map 2272 $map
2273 };
2274
2275 if ($@) {
2276 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2277 LOG llevError | logBacktrace, Carp::longmess $@;
1908 } or 2278 }
1909 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1910 2279
2280 if ($gen == $self->{_goto_generation}) {
2281 delete $self->{_goto_generation};
1911 $self->leave_link ($map, $x, $y); 2282 $self->leave_link ($map, $x, $y);
2283 }
1912 })->prio (1); 2284 })->prio (1);
1913} 2285}
1914 2286
1915=item $player_object->enter_exit ($exit_object) 2287=item $player_object->enter_exit ($exit_object)
1916 2288
1955 2327
1956 $rmp->{random_seed} ||= $exit->random_seed; 2328 $rmp->{random_seed} ||= $exit->random_seed;
1957 2329
1958 my $data = cf::to_json $rmp; 2330 my $data = cf::to_json $rmp;
1959 my $md5 = Digest::MD5::md5_hex $data; 2331 my $md5 = Digest::MD5::md5_hex $data;
1960 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2332 my $meta = "$RANDOMDIR/$md5.meta";
1961 2333
1962 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2334 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1963 aio_write $fh, 0, (length $data), $data, 0; 2335 aio_write $fh, 0, (length $data), $data, 0;
1964 undef $fh; 2336 undef $fh;
1965 aio_rename "$meta~", $meta; 2337 aio_rename "$meta~", $meta;
2021 2393
2022 utf8::encode $text; 2394 utf8::encode $text;
2023 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2395 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2024} 2396}
2025 2397
2398=item $client->send_msg ($color, $type, $msg, [extra...])
2399
2400Send a drawinfo or msg packet to the client, formatting the msg for the
2401client if neccessary. C<$type> should be a string identifying the type of
2402the message, with C<log> being the default. If C<$color> is negative, suppress
2403the message unless the client supports the msg packet.
2404
2405=cut
2406
2407sub cf::client::send_msg {
2408 my ($self, $color, $type, $msg, @extra) = @_;
2409
2410 $msg = $self->pl->expand_cfpod ($msg);
2411
2412 return unless @extra || length $msg;
2413
2414 if ($self->can_msg) {
2415 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2416 } else {
2417 # replace some tags by gcfclient-compatible ones
2418 for ($msg) {
2419 1 while
2420 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2421 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2422 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2423 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2424 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2425 }
2426
2427 if ($color >= 0) {
2428 if (0 && $msg =~ /\[/) {
2429 $self->send_packet ("drawextinfo $color 4 0 $msg")
2430 } else {
2431 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2432 $self->send_packet ("drawinfo $color $msg")
2433 }
2434 }
2435 }
2436}
2437
2026=item $client->ext_event ($type, %msg) 2438=item $client->ext_event ($type, %msg)
2027 2439
2028Sends an exti event to the client. 2440Sends an ext event to the client.
2029 2441
2030=cut 2442=cut
2031 2443
2032sub cf::client::ext_event($$%) { 2444sub cf::client::ext_event($$%) {
2033 my ($self, $type, %msg) = @_; 2445 my ($self, $type, %msg) = @_;
2034 2446
2035 $msg{msgtype} = "event_$type"; 2447 $msg{msgtype} = "event_$type";
2036 $self->send_packet ("ext " . cf::to_json \%msg); 2448 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2037} 2449}
2038 2450
2039=item $success = $client->query ($flags, "text", \&cb) 2451=item $success = $client->query ($flags, "text", \&cb)
2040 2452
2041Queues a query to the client, calling the given callback with 2453Queues a query to the client, calling the given callback with
2042the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2454the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2043C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2455C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2044 2456
2045Queries can fail, so check the return code. Or don't, as queries will become 2457Queries can fail, so check the return code. Or don't, as queries will
2046reliable at some point in the future. 2458become reliable at some point in the future.
2047 2459
2048=cut 2460=cut
2049 2461
2050sub cf::client::query { 2462sub cf::client::query {
2051 my ($self, $flags, $text, $cb) = @_; 2463 my ($self, $flags, $text, $cb) = @_;
2059 utf8::encode $text; 2471 utf8::encode $text;
2060 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2472 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2061 2473
2062 $self->send_packet ($self->{query_queue}[0][0]) 2474 $self->send_packet ($self->{query_queue}[0][0])
2063 if @{ $self->{query_queue} } == 1; 2475 if @{ $self->{query_queue} } == 1;
2476
2477 1
2064} 2478}
2065 2479
2066cf::client->attach ( 2480cf::client->attach (
2481 on_connect => sub {
2482 my ($ns) = @_;
2483
2484 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2485 },
2067 on_reply => sub { 2486 on_reply => sub {
2068 my ($ns, $msg) = @_; 2487 my ($ns, $msg) = @_;
2069 2488
2070 # this weird shuffling is so that direct followup queries 2489 # this weird shuffling is so that direct followup queries
2071 # get handled first 2490 # get handled first
2082 $ns->send_packet ($ns->{query_queue}[0][0]); 2501 $ns->send_packet ($ns->{query_queue}[0][0]);
2083 } else { 2502 } else {
2084 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2503 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2085 } 2504 }
2086 } 2505 }
2506 },
2507 on_exticmd => sub {
2508 my ($ns, $buf) = @_;
2509
2510 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2511
2512 if (ref $msg) {
2513 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2514 if (my %reply = $cb->($ns, $msg)) {
2515 $reply{msgid} = $msg->{msgid};
2516 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2517 }
2518 }
2519 } else {
2520 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2521 }
2522
2523 cf::override;
2087 }, 2524 },
2088); 2525);
2089 2526
2090=item $client->async (\&cb) 2527=item $client->async (\&cb)
2091 2528
2230=back 2667=back
2231 2668
2232=cut 2669=cut
2233 2670
2234############################################################################# 2671#############################################################################
2235
2236=head2 EXTENSION DATABASE SUPPORT
2237
2238Crossfire maintains a very simple database for extension use. It can
2239currently store anything that can be serialised using Storable, which
2240excludes objects.
2241
2242The parameter C<$family> should best start with the name of the extension
2243using it, it should be unique.
2244
2245=over 4
2246
2247=item $value = cf::db_get $family => $key
2248
2249Returns a single value from the database.
2250
2251=item cf::db_put $family => $key => $value
2252
2253Stores the given C<$value> in the family.
2254
2255=cut
2256
2257our $DB;
2258
2259sub db_init {
2260 unless ($DB) {
2261 $DB = BDB::db_create $DB_ENV;
2262
2263 cf::sync_job {
2264 eval {
2265 $DB->set_flags (BDB::CHKSUM);
2266
2267 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2268 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2269 cf::cleanup "db_open(db): $!" if $!;
2270 };
2271 cf::cleanup "db_open(db): $@" if $@;
2272 };
2273
2274 my $path = cf::localdir . "/database.pst";
2275 if (stat $path) {
2276 cf::sync_job {
2277 my $pst = Storable::retrieve $path;
2278
2279 cf::db_put (board => data => $pst->{board});
2280 cf::db_put (guildrules => data => $pst->{guildrules});
2281 cf::db_put (rent => balance => $pst->{rent}{balance});
2282 BDB::db_env_txn_checkpoint $DB_ENV;
2283
2284 unlink $path;
2285 };
2286 }
2287 }
2288}
2289
2290sub db_get($$) {
2291 my $key = "$_[0]/$_[1]";
2292
2293 cf::sync_job {
2294 BDB::db_get $DB, undef, $key, my $data;
2295
2296 $! ? ()
2297 : Compress::LZF::sthaw $data
2298 }
2299}
2300
2301sub db_put($$$) {
2302 BDB::dbreq_pri 4;
2303 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { };
2304}
2305
2306#############################################################################
2307# the server's init and main functions 2672# the server's init and main functions
2308 2673
2309sub load_facedata { 2674sub load_facedata($) {
2310 my $path = sprintf "%s/facedata", cf::datadir; 2675 my ($path) = @_;
2311 2676
2312 warn "loading facedata from $path\n"; 2677 warn "loading facedata from $path\n";
2313 2678
2314 my $facedata; 2679 my $facedata;
2315 0 < aio_load $path, $facedata 2680 0 < aio_load $path, $facedata
2356 } 2721 }
2357 2722
2358 1 2723 1
2359} 2724}
2360 2725
2726sub reload_regions {
2727 load_resource_file "$MAPDIR/regions"
2728 or die "unable to load regions file\n";
2729}
2730
2731sub reload_facedata {
2732 load_facedata "$DATADIR/facedata"
2733 or die "unable to load facedata\n";
2734}
2735
2736sub reload_archetypes {
2737 load_resource_file "$DATADIR/archetypes"
2738 or die "unable to load archetypes\n";
2739 #d# NEED to laod twice to resolve forward references
2740 # this really needs to be done in an extra post-pass
2741 # (which needs to be synchronous, so solve it differently)
2742 load_resource_file "$DATADIR/archetypes"
2743 or die "unable to load archetypes\n";
2744}
2745
2746sub reload_treasures {
2747 load_resource_file "$DATADIR/treasures"
2748 or die "unable to load treasurelists\n";
2749}
2750
2361sub reload_resources { 2751sub reload_resources {
2362 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 2752 warn "reloading resource files...\n";
2363 or die "unable to load regions file\n";#d# 2753
2754 reload_regions;
2364 load_facedata 2755 reload_facedata;
2365 or die "unable to load facedata\n";#d# 2756 #reload_archetypes;#d#
2757 reload_archetypes;
2758 reload_treasures;
2759
2760 warn "finished reloading resource files\n";
2366} 2761}
2367 2762
2368sub init { 2763sub init {
2369 reload_resources; 2764 reload_resources;
2370} 2765}
2371 2766
2372sub cfg_load { 2767sub cfg_load {
2373 open my $fh, "<:utf8", cf::confdir . "/config" 2768 open my $fh, "<:utf8", "$CONFDIR/config"
2374 or return; 2769 or return;
2375 2770
2376 local $/; 2771 local $/;
2377 *CFG = YAML::Syck::Load <$fh>; 2772 *CFG = YAML::Syck::Load <$fh>;
2378 2773
2423 }, 2818 },
2424 ); 2819 );
2425 } 2820 }
2426} 2821}
2427 2822
2823sub write_runtime {
2824 my $runtime = "$LOCALDIR/runtime";
2825
2826 # first touch the runtime file to show we are still running:
2827 # the fsync below can take a very very long time.
2828
2829 IO::AIO::aio_utime $runtime, undef, undef;
2830
2831 my $guard = cf::lock_acquire "write_runtime";
2832
2833 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2834 or return;
2835
2836 my $value = $cf::RUNTIME + 90 + 10;
2837 # 10 is the runtime save interval, for a monotonic clock
2838 # 60 allows for the watchdog to kill the server.
2839
2840 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2841 and return;
2842
2843 # always fsync - this file is important
2844 aio_fsync $fh
2845 and return;
2846
2847 # touch it again to show we are up-to-date
2848 aio_utime $fh, undef, undef;
2849
2850 close $fh
2851 or return;
2852
2853 aio_rename "$runtime~", $runtime
2854 and return;
2855
2856 warn "runtime file written.\n";
2857
2858 1
2859}
2860
2428sub emergency_save() { 2861sub emergency_save() {
2429 my $freeze_guard = cf::freeze_mainloop; 2862 my $freeze_guard = cf::freeze_mainloop;
2430 2863
2431 warn "enter emergency perl save\n"; 2864 warn "enter emergency perl save\n";
2432 2865
2463 2896
2464 warn Carp::longmess "post_cleanup backtrace" 2897 warn Carp::longmess "post_cleanup backtrace"
2465 if $make_core; 2898 if $make_core;
2466} 2899}
2467 2900
2468sub reload() { 2901sub do_reload_perl() {
2469 # can/must only be called in main 2902 # can/must only be called in main
2470 if ($Coro::current != $Coro::main) { 2903 if ($Coro::current != $Coro::main) {
2471 warn "can only reload from main coroutine"; 2904 warn "can only reload from main coroutine";
2472 return; 2905 return;
2473 } 2906 }
2507 %EXT_CORO = (); 2940 %EXT_CORO = ();
2508 2941
2509 warn "removing commands"; 2942 warn "removing commands";
2510 %COMMAND = (); 2943 %COMMAND = ();
2511 2944
2512 warn "removing ext commands"; 2945 warn "removing ext/exti commands";
2513 %EXTCMD = (); 2946 %EXTCMD = ();
2947 %EXTICMD = ();
2514 2948
2515 warn "unloading/nuking all extensions"; 2949 warn "unloading/nuking all extensions";
2516 for my $pkg (@EXTS) { 2950 for my $pkg (@EXTS) {
2517 warn "... unloading $pkg"; 2951 warn "... unloading $pkg";
2518 2952
2548 Symbol::delete_package "safe::$_" 2982 Symbol::delete_package "safe::$_"
2549 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2983 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2550 2984
2551 warn "unloading cf.pm \"a bit\""; 2985 warn "unloading cf.pm \"a bit\"";
2552 delete $INC{"cf.pm"}; 2986 delete $INC{"cf.pm"};
2987 delete $INC{"cf/pod.pm"};
2553 2988
2554 # don't, removes xs symbols, too, 2989 # don't, removes xs symbols, too,
2555 # and global variables created in xs 2990 # and global variables created in xs
2556 #Symbol::delete_package __PACKAGE__; 2991 #Symbol::delete_package __PACKAGE__;
2557 2992
2572 warn "reattaching attachments to maps"; 3007 warn "reattaching attachments to maps";
2573 reattach $_ for values %MAP; 3008 reattach $_ for values %MAP;
2574 warn "reattaching attachments to players"; 3009 warn "reattaching attachments to players";
2575 reattach $_ for values %PLAYER; 3010 reattach $_ for values %PLAYER;
2576 3011
2577 warn "loading reloadable resources";
2578 reload_resources;
2579
2580 warn "leaving sync_job"; 3012 warn "leaving sync_job";
2581 3013
2582 1 3014 1
2583 } or do { 3015 } or do {
2584 warn $@; 3016 warn $@;
2589 warn "reloaded"; 3021 warn "reloaded";
2590}; 3022};
2591 3023
2592our $RELOAD_WATCHER; # used only during reload 3024our $RELOAD_WATCHER; # used only during reload
2593 3025
3026sub reload_perl() {
3027 # doing reload synchronously and two reloads happen back-to-back,
3028 # coro crashes during coro_state_free->destroy here.
3029
3030 $RELOAD_WATCHER ||= Event->timer (
3031 reentrant => 0,
3032 after => 0,
3033 data => WF_AUTOCANCEL,
3034 cb => sub {
3035 do_reload_perl;
3036 undef $RELOAD_WATCHER;
3037 },
3038 );
3039}
3040
2594register_command "reload" => sub { 3041register_command "reload" => sub {
2595 my ($who, $arg) = @_; 3042 my ($who, $arg) = @_;
2596 3043
2597 if ($who->flag (FLAG_WIZ)) { 3044 if ($who->flag (FLAG_WIZ)) {
2598 $who->message ("reloading server."); 3045 $who->message ("reloading server.");
2599 3046 async { reload_perl };
2600 # doing reload synchronously and two reloads happen back-to-back,
2601 # coro crashes during coro_state_free->destroy here.
2602
2603 $RELOAD_WATCHER ||= Event->timer (
2604 reentrant => 0,
2605 after => 0,
2606 data => WF_AUTOCANCEL,
2607 cb => sub {
2608 reload;
2609 undef $RELOAD_WATCHER;
2610 },
2611 );
2612 } 3047 }
2613}; 3048};
2614 3049
2615unshift @INC, $LIBDIR; 3050unshift @INC, $LIBDIR;
2616 3051
2617my $bug_warning = 0; 3052my $bug_warning = 0;
2618 3053
3054our @WAIT_FOR_TICK;
3055our @WAIT_FOR_TICK_BEGIN;
3056
3057sub wait_for_tick {
3058 return unless $TICK_WATCHER->is_active;
3059 return if $Coro::current == $Coro::main;
3060
3061 my $signal = new Coro::Signal;
3062 push @WAIT_FOR_TICK, $signal;
3063 $signal->wait;
3064}
3065
3066sub wait_for_tick_begin {
3067 return unless $TICK_WATCHER->is_active;
3068 return if $Coro::current == $Coro::main;
3069
3070 my $signal = new Coro::Signal;
3071 push @WAIT_FOR_TICK_BEGIN, $signal;
3072 $signal->wait;
3073}
3074
3075 my $min = 1e6;#d#
3076 my $avg = 10;
2619$TICK_WATCHER = Event->timer ( 3077$TICK_WATCHER = Event->timer (
2620 reentrant => 0, 3078 reentrant => 0,
2621 parked => 1, 3079 parked => 1,
2622 prio => 0, 3080 prio => 0,
2623 at => $NEXT_TICK || $TICK, 3081 at => $NEXT_TICK || $TICK,
2627 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3085 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2628 unless ++$bug_warning > 10; 3086 unless ++$bug_warning > 10;
2629 return; 3087 return;
2630 } 3088 }
2631 3089
2632 $NOW = Event::time; 3090 $NOW = $tick_start = Event::time;
2633 3091
2634 cf::server_tick; # one server iteration 3092 cf::server_tick; # one server iteration
3093
3094 0 && sync_job {#d#
3095 for(1..10) {
3096 my $t = Event::time;
3097 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3098 or die;
3099
3100 $map->width (50);
3101 $map->height (50);
3102 $map->alloc;
3103 $map->_load_objects ("/tmp/x.map", 1);
3104 my $t = Event::time - $t;
3105
3106 #next unless $t < 0.0013;#d#
3107 if ($t < $min) {
3108 $min = $t;
3109 }
3110 $avg = $avg * 0.99 + $t * 0.01;
3111 }
3112 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3113 exit 0;
3114 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3115 };
3116
2635 $RUNTIME += $TICK; 3117 $RUNTIME += $TICK;
2636 $NEXT_TICK += $TICK; 3118 $NEXT_TICK += $TICK;
2637 3119
2638 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3120 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2639 $NEXT_RUNTIME_WRITE = $NOW + 10; 3121 $NEXT_RUNTIME_WRITE = $NOW + 10;
2641 write_runtime 3123 write_runtime
2642 or warn "ERROR: unable to write runtime file: $!"; 3124 or warn "ERROR: unable to write runtime file: $!";
2643 }; 3125 };
2644 } 3126 }
2645 3127
2646 $WAIT_FOR_TICK->broadcast;
2647 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2648
2649# my $AFTER = Event::time; 3128# my $AFTER = Event::time;
2650# warn $AFTER - $NOW;#d# 3129# warn $AFTER - $NOW;#d#
2651 3130
3131 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3132 $sig->send;
3133 }
3134 while (my $sig = shift @WAIT_FOR_TICK) {
3135 $sig->send;
3136 }
3137
3138 $NOW = Event::time;
3139
2652 # if we are delayed by four ticks or more, skip them all 3140 # if we are delayed by four ticks or more, skip them all
2653 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3141 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2654 3142
2655 $TICK_WATCHER->at ($NEXT_TICK); 3143 $TICK_WATCHER->at ($NEXT_TICK);
2656 $TICK_WATCHER->start; 3144 $TICK_WATCHER->start;
3145
3146 $LOAD = ($NOW - $tick_start) / $TICK;
3147 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3148
3149 _post_tick;
3150
3151
2657 }, 3152 },
2658); 3153);
2659 3154
2660{ 3155{
2661 BDB::max_poll_time $TICK * 0.1; 3156 BDB::max_poll_time $TICK * 0.1;
2689 3184
2690 cf::sync_job { 3185 cf::sync_job {
2691 eval { 3186 eval {
2692 BDB::db_env_open 3187 BDB::db_env_open
2693 $DB_ENV, 3188 $DB_ENV,
2694 $BDB_ENV_DIR, 3189 $BDBDIR,
2695 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3190 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2696 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3191 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2697 0666; 3192 0666;
2698 3193
2699 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 3194 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2700 3195
2701 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3196 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2702 $DB_ENV->set_lk_detect; 3197 $DB_ENV->set_lk_detect;
2703 }; 3198 };
2704 3199
2720 prio => 6, 3215 prio => 6,
2721 cb => \&IO::AIO::poll_cb, 3216 cb => \&IO::AIO::poll_cb,
2722 ); 3217 );
2723} 3218}
2724 3219
3220my $_log_backtrace;
3221
3222sub _log_backtrace {
3223 my ($msg, @addr) = @_;
3224
3225 $msg =~ s/\n//;
3226
3227 # limit the # of concurrent backtraces
3228 if ($_log_backtrace < 2) {
3229 ++$_log_backtrace;
3230 async {
3231 my @bt = fork_call {
3232 @addr = map { sprintf "%x", $_ } @addr;
3233 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3234 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3235 or die "addr2line: $!";
3236
3237 my @funcs;
3238 my @res = <$fh>;
3239 chomp for @res;
3240 while (@res) {
3241 my ($func, $line) = splice @res, 0, 2, ();
3242 push @funcs, "[$func] $line";
3243 }
3244
3245 @funcs
3246 };
3247
3248 LOG llevInfo, "[ABT] $msg\n";
3249 LOG llevInfo, "[ABT] $_\n" for @bt;
3250 --$_log_backtrace;
3251 };
3252 } else {
3253 LOG llevInfo, "[ABT] $msg\n";
3254 LOG llevInfo, "[ABT] [suppressed]\n";
3255 }
3256}
3257
3258# load additional modules
3259use cf::pod;
3260
2725END { cf::emergency_save } 3261END { cf::emergency_save }
2726 3262
27271 32631
2728 3264

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines