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.100 by root, Mon Dec 25 11:25:49 2006 UTC vs.
Revision 1.284 by root, Sun Jun 24 04:15: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;
10use Event;
9use Opcode; 11use Opcode;
10use Safe; 12use Safe;
11use Safe::Hole; 13use Safe::Hole;
12 14
13use Coro; 15use Coro 3.61 ();
16use Coro::State;
17use Coro::Handle;
14use Coro::Event; 18use Coro::Event;
15use Coro::Timer; 19use Coro::Timer;
16use Coro::Signal; 20use Coro::Signal;
17use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO;
23use Coro::Storable;
18 24
19use IO::AIO 2.3; 25use BDB ();
26use Data::Dumper;
27use Digest::MD5;
28use Fcntl;
20use YAML::Syck (); 29use YAML::Syck ();
30use IO::AIO 2.32 ();
21use Time::HiRes; 31use Time::HiRes;
32use Compress::LZF;
22 33
34# configure various modules to our taste
35#
36$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39
23use Event; $Event::Eval = 1; # no idea why this is required, but it is 40$Event::Eval = 1; # no idea why this is required, but it is
24 41
25# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
26$YAML::Syck::ImplicitUnicode = 1; 43$YAML::Syck::ImplicitUnicode = 1;
27 44
28$Coro::main->prio (Coro::PRIO_MIN); 45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
29 46
30sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
31 48
32our %COMMAND = (); 49our %COMMAND = ();
33our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
51
52our @EXTS = (); # list of extension package names
34our %EXTCMD = (); 53our %EXTCMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps
35 56
57our $RELOAD; # number of reloads so far
36our @EVENT; 58our @EVENT;
37our $LIBDIR = datadir . "/ext";
38 59
39our $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(!)
40our $TICK_WATCHER; 73our $TICK_WATCHER;
74our $AIO_POLL_WATCHER;
75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
41our $NEXT_TICK; 76our $NEXT_TICK;
77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off
79
80our $BDB_POLL_WATCHER;
81our $DB_ENV;
42 82
43our %CFG; 83our %CFG;
44 84
45our $UPTIME; $UPTIME ||= time; 85our $UPTIME; $UPTIME ||= time;
86our $RUNTIME;
87
88our %PLAYER; # all users
89our %MAP; # all maps
90our $LINK_MAP; # the special {link} map, which is always available
91
92# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
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
99binmode STDOUT;
100binmode STDERR;
101
102# read virtual server time, if available
103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
104 open my $fh, "<", "$LOCALDIR/runtime"
105 or die "unable to read runtime file: $!";
106 $RUNTIME = <$fh> + 0.;
107}
108
109mkdir $_
110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
111
112our $EMERGENCY_POSITION;
113
114sub cf::map::normalise;
46 115
47############################################################################# 116#############################################################################
48 117
49=head2 GLOBAL VARIABLES 118=head2 GLOBAL VARIABLES
50 119
… …
52 121
53=item $cf::UPTIME 122=item $cf::UPTIME
54 123
55The timestamp of the server start (so not actually an uptime). 124The timestamp of the server start (so not actually an uptime).
56 125
57=item $cf::LIBDIR 126=item $cf::RUNTIME
58 127
59The perl library directory, where extensions and cf-specific modules can 128The time this server has run, starts at 0 and is increased by $cf::TICK on
60be found. It will be added to C<@INC> automatically. 129every server tick.
130
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
134
135Various directories - "/etc", read-only install directory, perl-library
136directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
137unique-items directory, player file directory, random maps directory and
138database environment.
139
140=item $cf::NOW
141
142The time of the last (current) server tick.
61 143
62=item $cf::TICK 144=item $cf::TICK
63 145
64The 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.
65 157
66=item %cf::CFG 158=item %cf::CFG
67 159
68Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
69from wherever your confdir points to. 161from wherever your confdir points to.
162
163=item cf::wait_for_tick, cf::wait_for_tick_begin
164
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166returns directly I<after> the tick processing (and consequently, can only wake one process
167per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
70 168
71=back 169=back
72 170
73=cut 171=cut
74 172
75BEGIN { 173BEGIN {
76 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
77 my $msg = join "", @_; 175 my $msg = join "", @_;
176
78 $msg .= "\n" 177 $msg .= "\n"
79 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
80 179
81 print STDERR "cfperl: $msg"; 180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
82 LOG llevError, "cfperl: $msg"; 183 LOG llevError, $msg;
83 }; 184 };
84} 185}
85 186
86@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
87@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
88@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
89@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
90@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';
91@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)
92 194
93# 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
94# within the Safe compartment. 196# within the Safe compartment.
95for my $pkg (qw( 197for my $pkg (qw(
96 cf::global cf::attachable 198 cf::global cf::attachable
… …
105 207
106$Event::DIED = sub { 208$Event::DIED = sub {
107 warn "error in event callback: @_"; 209 warn "error in event callback: @_";
108}; 210};
109 211
110my %ext_pkg; 212#############################################################################
111my @exts;
112my @hook;
113 213
114=head2 UTILITY FUNCTIONS 214=head2 UTILITY FUNCTIONS
115 215
116=over 4 216=over 4
117 217
118=cut 218=item dumpval $ref
119 219
220=cut
221
222sub dumpval {
223 eval {
224 local $SIG{__DIE__};
225 my $d;
226 if (1) {
227 $d = new Data::Dumper([$_[0]], ["*var"]);
228 $d->Terse(1);
229 $d->Indent(2);
230 $d->Quotekeys(0);
231 $d->Useqq(1);
232 #$d->Bless(...);
233 $d->Seen($_[1]) if @_ > 1;
234 $d = $d->Dump();
235 }
236 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
237 $d
238 } || "[unable to dump $_[0]: '$@']";
239}
240
120use JSON::Syck (); # TODO# replace by JSON::PC once working 241use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
121 242
122=item $ref = cf::from_json $json 243=item $ref = cf::from_json $json
123 244
124Converts a JSON string into the corresponding perl data structure. 245Converts a JSON string into the corresponding perl data structure.
125 246
126=cut
127
128sub from_json($) {
129 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
130 JSON::Syck::Load $_[0]
131}
132
133=item $json = cf::to_json $ref 247=item $json = cf::to_json $ref
134 248
135Converts a perl data structure into its JSON representation. 249Converts a perl data structure into its JSON representation.
136 250
137=cut 251=item cf::lock_wait $string
138 252
139sub to_json($) { 253Wait until the given lock is available. See cf::lock_acquire.
140 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 254
141 JSON::Syck::Dump $_[0] 255=item my $lock = cf::lock_acquire $string
256
257Wait until the given lock is available and then acquires it and returns
258a Coro::guard object. If the guard object gets destroyed (goes out of scope,
259for example when the coroutine gets canceled), the lock is automatically
260returned.
261
262Lock names should begin with a unique identifier (for example, cf::map::find
263uses map_find and cf::map::load uses map_load).
264
265=item $locked = cf::lock_active $string
266
267Return true if the lock is currently active, i.e. somebody has locked it.
268
269=cut
270
271our %LOCK;
272
273sub lock_wait($) {
274 my ($key) = @_;
275
276 # wait for lock, if any
277 while ($LOCK{$key}) {
278 push @{ $LOCK{$key} }, $Coro::current;
279 Coro::schedule;
280 }
281}
282
283sub lock_acquire($) {
284 my ($key) = @_;
285
286 # wait, to be sure we are not locked
287 lock_wait $key;
288
289 $LOCK{$key} = [];
290
291 Coro::guard {
292 # wake up all waiters, to be on the safe side
293 $_->ready for @{ delete $LOCK{$key} };
294 }
295}
296
297sub lock_active($) {
298 my ($key) = @_;
299
300 ! ! $LOCK{$key}
301}
302
303sub freeze_mainloop {
304 return unless $TICK_WATCHER->is_active;
305
306 my $guard = Coro::guard {
307 $TICK_WATCHER->start;
308 };
309 $TICK_WATCHER->stop;
310 $guard
311}
312
313=item cf::async { BLOCK }
314
315Currently the same as Coro::async_pool, meaning you cannot use
316C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
317thing you are allowed to do is call C<prio> on it.
318
319=cut
320
321BEGIN { *async = \&Coro::async_pool }
322
323=item cf::sync_job { BLOCK }
324
325The design of Crossfire TRT requires that the main coroutine ($Coro::main)
326is always able to handle events or runnable, as Crossfire TRT is only
327partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
328acceptable.
329
330If it must be done, put the blocking parts into C<sync_job>. This will run
331the given BLOCK in another coroutine while waiting for the result. The
332server will be frozen during this time, so the block should either finish
333fast or be very important.
334
335=cut
336
337sub sync_job(&) {
338 my ($job) = @_;
339
340 if ($Coro::current == $Coro::main) {
341 my $time = Event::time;
342
343 # this is the main coro, too bad, we have to block
344 # till the operation succeeds, freezing the server :/
345
346 # TODO: use suspend/resume instead
347 # (but this is cancel-safe)
348 my $freeze_guard = freeze_mainloop;
349
350 my $busy = 1;
351 my @res;
352
353 (async {
354 @res = eval { $job->() };
355 warn $@ if $@;
356 undef $busy;
357 })->prio (Coro::PRIO_MAX);
358
359 while ($busy) {
360 Coro::cede or Event::one_event;
361 }
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
370 wantarray ? @res : $res[0]
371 } else {
372 # we are in another coroutine, how wonderful, everything just works
373
374 $job->()
375 }
376}
377
378=item $coro = cf::async_ext { BLOCK }
379
380Like async, but this coro is automatically being canceled when the
381extension calling this is being unloaded.
382
383=cut
384
385sub async_ext(&) {
386 my $cb = shift;
387
388 my $coro = &Coro::async ($cb);
389
390 $coro->on_destroy (sub {
391 delete $EXT_CORO{$coro+0};
392 });
393 $EXT_CORO{$coro+0} = $coro;
394
395 $coro
396}
397
398=item fork_call { }, $args
399
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.
404
405=cut
406
407sub fork_call(&@) {
408 my ($cb, @args) = @_;
409
410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
411# or die "socketpair: $!";
412 pipe my $fh1, my $fh2
413 or die "pipe: $!";
414
415 if (my $pid = fork) {
416 close $fh2;
417
418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
419 $res = Coro::Storable::thaw $res;
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;
439 }
440}
441
442=item $value = cf::db_get $family => $key
443
444Returns a single value from the environment database.
445
446=item cf::db_put $family => $key => $value
447
448Stores the given C<$value> in the family. It can currently store binary
449data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450
451=cut
452
453our $DB;
454
455sub db_init {
456 unless ($DB) {
457 $DB = BDB::db_create $DB_ENV;
458
459 cf::sync_job {
460 eval {
461 $DB->set_flags (BDB::CHKSUM);
462
463 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465 cf::cleanup "db_open(db): $!" if $!;
466 };
467 cf::cleanup "db_open(db): $@" if $@;
468 };
469 }
470}
471
472sub db_get($$) {
473 my $key = "$_[0]/$_[1]";
474
475 cf::sync_job {
476 BDB::db_get $DB, undef, $key, my $data;
477
478 $! ? ()
479 : $data
480 }
481}
482
483sub db_put($$$) {
484 BDB::dbreq_pri 4;
485 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
486}
487
488=item cf::cache $id => [$paths...], $processversion => $process
489
490Generic caching function that returns the value of the resource $id,
491caching and regenerating as required.
492
493This function can block.
494
495=cut
496
497sub cache {
498 my ($id, $src, $processversion, $process) = @_;
499
500 my $meta =
501 join "\x00",
502 $processversion,
503 map {
504 aio_stat $_
505 and Carp::croak "$_: $!";
506
507 ($_, (stat _)[7,9])
508 } @$src;
509
510 my $dbmeta = db_get cache => "$id/meta";
511 if ($dbmeta ne $meta) {
512 # changed, we may need to process
513
514 my @data;
515 my $md5;
516
517 for (0 .. $#$src) {
518 0 <= aio_load $src->[$_], $data[$_]
519 or Carp::croak "$src->[$_]: $!";
520 }
521
522 # if processing is expensive, check
523 # checksum first
524 if (1) {
525 $md5 =
526 join "\x00",
527 $processversion,
528 map {
529 Coro::cede;
530 ($src->[$_], Digest::MD5::md5_hex $data[$_])
531 } 0.. $#$src;
532
533
534 my $dbmd5 = db_get cache => "$id/md5";
535 if ($dbmd5 eq $md5) {
536 db_put cache => "$id/meta", $meta;
537
538 return db_get cache => "$id/data";
539 }
540 }
541
542 my $t1 = Time::HiRes::time;
543 my $data = $process->(\@data);
544 my $t2 = Time::HiRes::time;
545
546 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
547
548 db_put cache => "$id/data", $data;
549 db_put cache => "$id/md5" , $md5;
550 db_put cache => "$id/meta", $meta;
551
552 return $data;
553 }
554
555 db_get cache => "$id/data"
556}
557
558=item cf::datalog type => key => value, ...
559
560Log a datalog packet of the given type with the given key-value pairs.
561
562=cut
563
564sub datalog($@) {
565 my ($type, %kv) = @_;
566 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
142} 567}
143 568
144=back 569=back
145 570
146=cut 571=cut
… …
153attach callbacks/event handlers (a collection of which is called an "attachment") 578attach callbacks/event handlers (a collection of which is called an "attachment")
154to it. All such attachable objects support the following methods. 579to it. All such attachable objects support the following methods.
155 580
156In 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>
157C<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
158crossfire+). 583Crossfire TRT).
159 584
160=over 4 585=over 4
161 586
162=item $attachable->attach ($attachment, key => $value...) 587=item $attachable->attach ($attachment, key => $value...)
163 588
… …
277our @CB_TYPE = (); # registry for type (cf-object class) based events 702our @CB_TYPE = (); # registry for type (cf-object class) based events
278our @CB_MAP = (); 703our @CB_MAP = ();
279 704
280my %attachment; 705my %attachment;
281 706
707sub cf::attachable::thawer_merge {
708 # simply override everything except _meta
709 local $_[0]{_meta};
710 %{$_[0]} = %{$_[1]};
711}
712
282sub _attach_cb($$$$) { 713sub _attach_cb($$$$) {
283 my ($registry, $event, $prio, $cb) = @_; 714 my ($registry, $event, $prio, $cb) = @_;
284 715
285 use sort 'stable'; 716 use sort 'stable';
286 717
… …
320 $registry = $CB_TYPE[$object_type] ||= []; 751 $registry = $CB_TYPE[$object_type] ||= [];
321 752
322 } elsif ($type eq "subtype") { 753 } elsif ($type eq "subtype") {
323 defined $object_type or Carp::croak "subtype specified without type"; 754 defined $object_type or Carp::croak "subtype specified without type";
324 my $object_subtype = shift @arg; 755 my $object_subtype = shift @arg;
325 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 756 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
326 757
327 } elsif ($type eq "package") { 758 } elsif ($type eq "package") {
328 my $pkg = shift @arg; 759 my $pkg = shift @arg;
329 760
330 while (my ($name, $id) = each %cb_id) { 761 while (my ($name, $id) = each %cb_id) {
… …
359 _attach $registry, $klass, @attach; 790 _attach $registry, $klass, @attach;
360 } 791 }
361 792
362 $obj->{$name} = \%arg; 793 $obj->{$name} = \%arg;
363 } else { 794 } else {
364 warn "object uses attachment '$name' that is not available, postponing.\n"; 795 warn "object uses attachment '$name' which is not available, postponing.\n";
365 } 796 }
366 797
367 $obj->{_attachment}{$name} = undef; 798 $obj->{_attachment}{$name} = undef;
368} 799}
369 800
… …
371 if (ref $_[0]) { 802 if (ref $_[0]) {
372 _object_attach @_; 803 _object_attach @_;
373 } else { 804 } else {
374 _attach shift->_attach_registry, @_; 805 _attach shift->_attach_registry, @_;
375 } 806 }
807 _recalc_want;
376}; 808};
377 809
378# all those should be optimised 810# all those should be optimised
379sub cf::attachable::detach { 811sub cf::attachable::detach {
380 my ($obj, $name) = @_; 812 my ($obj, $name) = @_;
… …
383 delete $obj->{_attachment}{$name}; 815 delete $obj->{_attachment}{$name};
384 reattach ($obj); 816 reattach ($obj);
385 } else { 817 } else {
386 Carp::croak "cannot, currently, detach class attachments"; 818 Carp::croak "cannot, currently, detach class attachments";
387 } 819 }
820 _recalc_want;
388}; 821};
389 822
390sub cf::attachable::attached { 823sub cf::attachable::attached {
391 my ($obj, $name) = @_; 824 my ($obj, $name) = @_;
392 825
… …
454=cut 887=cut
455 888
456############################################################################# 889#############################################################################
457# object support 890# object support
458 891
892sub reattach {
893 # basically do the same as instantiate, without calling instantiate
894 my ($obj) = @_;
895
896 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
897
898 my $registry = $obj->registry;
899
900 @$registry = ();
901
902 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
903
904 for my $name (keys %{ $obj->{_attachment} || {} }) {
905 if (my $attach = $attachment{$name}) {
906 for (@$attach) {
907 my ($klass, @attach) = @$_;
908 _attach $registry, $klass, @attach;
909 }
910 } else {
911 warn "object uses attachment '$name' that is not available, postponing.\n";
912 }
913 }
914}
915
459cf::attachable->attach ( 916cf::attachable->attach (
460 prio => -1000000, 917 prio => -1000000,
461 on_instantiate => sub { 918 on_instantiate => sub {
462 my ($obj, $data) = @_; 919 my ($obj, $data) = @_;
463 920
… …
467 my ($name, $args) = @$_; 924 my ($name, $args) = @$_;
468 925
469 $obj->attach ($name, %{$args || {} }); 926 $obj->attach ($name, %{$args || {} });
470 } 927 }
471 }, 928 },
472 on_reattach => sub { 929 on_reattach => \&reattach,
473 # basically do the same as instantiate, without calling instantiate
474 my ($obj) = @_;
475 my $registry = $obj->registry;
476
477 @$registry = ();
478
479 delete $obj->{_attachment} unless scalar keys %{ $obj->{_attachment} || {} };
480
481 for my $name (keys %{ $obj->{_attachment} || {} }) {
482 if (my $attach = $attachment{$name}) {
483 for (@$attach) {
484 my ($klass, @attach) = @$_;
485 _attach $registry, $klass, @attach;
486 }
487 } else {
488 warn "object uses attachment '$name' that is not available, postponing.\n";
489 }
490 }
491 },
492 on_clone => sub { 930 on_clone => sub {
493 my ($src, $dst) = @_; 931 my ($src, $dst) = @_;
494 932
495 @{$dst->registry} = @{$src->registry}; 933 @{$dst->registry} = @{$src->registry};
496 934
… …
502); 940);
503 941
504sub object_freezer_save { 942sub object_freezer_save {
505 my ($filename, $rdata, $objs) = @_; 943 my ($filename, $rdata, $objs) = @_;
506 944
945 sync_job {
507 if (length $$rdata) { 946 if (length $$rdata) {
508 warn sprintf "saving %s (%d,%d)\n", 947 warn sprintf "saving %s (%d,%d)\n",
509 $filename, length $$rdata, scalar @$objs; 948 $filename, length $$rdata, scalar @$objs;
510 949
511 if (open my $fh, ">:raw", "$filename~") { 950 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
512 chmod SAVE_MODE, $fh;
513 syswrite $fh, $$rdata;
514 close $fh;
515
516 if (@$objs && open my $fh, ">:raw", "$filename.pst~") {
517 chmod SAVE_MODE, $fh; 951 chmod SAVE_MODE, $fh;
518 syswrite $fh, Storable::nfreeze { version => 1, objs => $objs }; 952 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
953 aio_fsync $fh if $cf::USE_FSYNC;
519 close $fh; 954 close $fh;
955
956 if (@$objs) {
957 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
958 chmod SAVE_MODE, $fh;
959 my $data = Storable::nfreeze { version => 1, objs => $objs };
960 aio_write $fh, 0, (length $data), $data, 0;
961 aio_fsync $fh if $cf::USE_FSYNC;
962 close $fh;
520 rename "$filename.pst~", "$filename.pst"; 963 aio_rename "$filename.pst~", "$filename.pst";
964 }
965 } else {
966 aio_unlink "$filename.pst";
967 }
968
969 aio_rename "$filename~", $filename;
521 } else { 970 } else {
522 unlink "$filename.pst"; 971 warn "FATAL: $filename~: $!\n";
523 } 972 }
524
525 rename "$filename~", $filename;
526 } else { 973 } else {
527 warn "FATAL: $filename~: $!\n";
528 }
529 } else {
530 unlink $filename; 974 aio_unlink $filename;
531 unlink "$filename.pst"; 975 aio_unlink "$filename.pst";
976 }
532 } 977 }
533} 978}
534 979
535sub object_freezer_as_string { 980sub object_freezer_as_string {
536 my ($rdata, $objs) = @_; 981 my ($rdata, $objs) = @_;
… …
541} 986}
542 987
543sub object_thawer_load { 988sub object_thawer_load {
544 my ($filename) = @_; 989 my ($filename) = @_;
545 990
546 local $/; 991 my ($data, $av);
547 992
548 my $av; 993 (aio_load $filename, $data) >= 0
994 or return;
549 995
550 #TODO: use sysread etc. 996 unless (aio_stat "$filename.pst") {
551 if (open my $data, "<:raw:perlio", $filename) { 997 (aio_load "$filename.pst", $av) >= 0
552 $data = <$data>; 998 or return;
553 if (open my $pst, "<:raw:perlio", "$filename.pst") {
554 $av = eval { (Storable::thaw <$pst>)->{objs} }; 999 $av = eval { (Storable::thaw $av)->{objs} };
555 } 1000 }
1001
1002 warn sprintf "loading %s (%d)\n",
1003 $filename, length $data, scalar @{$av || []};
556 return ($data, $av); 1004 return ($data, $av);
557 }
558
559 ()
560} 1005}
1006
1007=head2 COMMAND CALLBACKS
1008
1009=over 4
1010
1011=cut
561 1012
562############################################################################# 1013#############################################################################
563# command handling &c 1014# command handling &c
564 1015
565=item cf::register_command $name => \&callback($ob,$args); 1016=item cf::register_command $name => \&callback($ob,$args);
… …
578 push @{ $COMMAND{$name} }, [$caller, $cb]; 1029 push @{ $COMMAND{$name} }, [$caller, $cb];
579} 1030}
580 1031
581=item cf::register_extcmd $name => \&callback($pl,$packet); 1032=item cf::register_extcmd $name => \&callback($pl,$packet);
582 1033
583Register a callbackf ro execution when the client sends an extcmd packet. 1034Register a callback fro execution when the client sends an extcmd packet.
584 1035
585If 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
586called. 1037called.
587 1038
588=cut 1039=cut
589 1040
590sub register_extcmd { 1041sub register_extcmd {
591 my ($name, $cb) = @_; 1042 my ($name, $cb) = @_;
592 1043
593 my $caller = caller;
594 #warn "registering extcmd '$name' to '$caller'";
595
596 $EXTCMD{$name} = [$cb, $caller]; 1044 $EXTCMD{$name} = $cb;
597} 1045}
598 1046
599cf::player->attach ( 1047cf::player->attach (
600 on_command => sub { 1048 on_command => sub {
601 my ($pl, $name, $params) = @_; 1049 my ($pl, $name, $params) = @_;
… …
614 1062
615 my $msg = eval { from_json $buf }; 1063 my $msg = eval { from_json $buf };
616 1064
617 if (ref $msg) { 1065 if (ref $msg) {
618 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1066 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
619 if (my %reply = $cb->[0]->($pl, $msg)) { 1067 if (my %reply = $cb->($pl, $msg)) {
620 $pl->ext_reply ($msg->{msgid}, %reply); 1068 $pl->ext_reply ($msg->{msgid}, %reply);
621 } 1069 }
622 } 1070 }
623 } else { 1071 } else {
624 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1072 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
… …
626 1074
627 cf::override; 1075 cf::override;
628 }, 1076 },
629); 1077);
630 1078
1079sub load_extensions {
1080 cf::sync_job {
1081 my %todo;
1082
1083 for my $path (<$LIBDIR/*.ext>) {
1084 next unless -r $path;
1085
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;
1143 }
1144
1145 skip:
1146 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1147 unless $progress;
1148 }
1149 };
1150}
1151
1152#############################################################################
1153
1154=back
1155
1156=head2 CORE EXTENSIONS
1157
1158Functions and methods that extend core crossfire objects.
1159
1160=cut
1161
1162package cf::player;
1163
1164use Coro::AIO;
1165
1166=head3 cf::player
1167
1168=over 4
1169
1170=item cf::player::find $login
1171
1172Returns the given player object, loading it if necessary (might block).
1173
1174=cut
1175
1176sub playerdir($) {
1177 "$PLAYERDIR/"
1178 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1179}
1180
1181sub path($) {
1182 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1183
1184 (playerdir $login) . "/playerdata"
1185}
1186
1187sub find_active($) {
1188 $cf::PLAYER{$_[0]}
1189 and $cf::PLAYER{$_[0]}->active
1190 and $cf::PLAYER{$_[0]}
1191}
1192
1193sub exists($) {
1194 my ($login) = @_;
1195
1196 $cf::PLAYER{$login}
1197 or cf::sync_job { !aio_stat path $login }
1198}
1199
1200sub find($) {
1201 return $cf::PLAYER{$_[0]} || do {
1202 my $login = $_[0];
1203
1204 my $guard = cf::lock_acquire "user_find:$login";
1205
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
1214 my $pl = load_pl path $login
1215 or return;
1216 $cf::PLAYER{$login} = $pl
1217 }
1218 }
1219}
1220
1221sub save($) {
1222 my ($pl) = @_;
1223
1224 return if $pl->{deny_save};
1225
1226 my $path = path $pl;
1227 my $guard = cf::lock_acquire "user_save:$path";
1228
1229 return if $pl->{deny_save};
1230
1231 aio_mkdir playerdir $pl, 0770;
1232 $pl->{last_save} = $cf::RUNTIME;
1233
1234 $pl->save_pl ($path);
1235 Coro::cede;
1236}
1237
1238sub new($) {
1239 my ($login) = @_;
1240
1241 my $self = create;
1242
1243 $self->ob->name ($login);
1244 $self->{deny_save} = 1;
1245
1246 $cf::PLAYER{$login} = $self;
1247
1248 $self
1249}
1250
1251=item $pl->quit_character
1252
1253Nukes the player without looking back. If logged in, the connection will
1254be destroyed. May block for a long time.
1255
1256=cut
1257
1258sub quit_character {
1259 my ($pl) = @_;
1260
1261 my $name = $pl->ob->name;
1262
1263 $pl->{deny_save} = 1;
1264 $pl->password ("*"); # this should lock out the player until we nuked the dir
1265
1266 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1267 $pl->deactivate;
1268 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1269 $pl->ns->destroy if $pl->ns;
1270
1271 my $path = playerdir $pl;
1272 my $temp = "$path~$cf::RUNTIME~deleting~";
1273 aio_rename $path, $temp;
1274 delete $cf::PLAYER{$pl->ob->name};
1275 $pl->destroy;
1276
1277 my $prefix = qr<^~\Q$name\E/>;
1278
1279 # nuke player maps
1280 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1281
1282 IO::AIO::aio_rmtree $temp;
1283}
1284
1285=item $pl->kick
1286
1287Kicks a player out of the game. This destroys the connection.
1288
1289=cut
1290
1291sub kick {
1292 my ($pl, $kicker) = @_;
1293
1294 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1295 $pl->killer ("kicked");
1296 $pl->ns->destroy;
1297}
1298
1299=item cf::player::list_logins
1300
1301Returns am arrayref of all valid playernames in the system, can take a
1302while and may block, so not sync_job-capable, ever.
1303
1304=cut
1305
1306sub list_logins {
1307 my $dirs = aio_readdir $PLAYERDIR
1308 or return [];
1309
1310 my @logins;
1311
1312 for my $login (@$dirs) {
1313 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1314 aio_read $fh, 0, 512, my $buf, 0 or next;
1315 $buf !~ /^password -------------$/m or next; # official not-valid tag
1316
1317 utf8::decode $login;
1318 push @logins, $login;
1319 }
1320
1321 \@logins
1322}
1323
1324=item $player->maps
1325
1326Returns an arrayref of map paths that are private for this
1327player. May block.
1328
1329=cut
1330
1331sub maps($) {
1332 my ($pl) = @_;
1333
1334 $pl = ref $pl ? $pl->ob->name : $pl;
1335
1336 my $files = aio_readdir playerdir $pl
1337 or return;
1338
1339 my @paths;
1340
1341 for (@$files) {
1342 utf8::decode $_;
1343 next if /\.(?:pl|pst)$/;
1344 next unless /^$PATH_SEP/o;
1345
1346 push @paths, cf::map::normalise "~$pl/$_";
1347 }
1348
1349 \@paths
1350}
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
1385=item $player->ext_reply ($msgid, %msg)
1386
1387Sends an ext reply to the player.
1388
1389=cut
1390
1391sub ext_reply($$%) {
1392 my ($self, $id, %msg) = @_;
1393
1394 $msg{msgid} = $id;
1395
1396 $self->send ("ext " . cf::to_json \%msg);
1397}
1398
1399=item $player->ext_event ($type, %msg)
1400
1401Sends an ext event to the client.
1402
1403=cut
1404
1405sub ext_event($$%) {
1406 my ($self, $type, %msg) = @_;
1407
1408 $self->ns->ext_event ($type, %msg);
1409}
1410
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}
1439
1440=back
1441
1442=head3 cf::map
1443
1444=over 4
1445
1446=cut
1447
1448package cf::map;
1449
1450use Fcntl;
1451use Coro::AIO;
1452
1453use overload
1454 '""' => \&as_string,
1455 fallback => 1;
1456
1457our $MAX_RESET = 3600;
1458our $DEFAULT_RESET = 3000;
1459
1460sub generate_random_map {
1461 my ($self, $rmp) = @_;
1462 # mit "rum" bekleckern, nicht
1463 $self->_create_random_map (
1464 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1465 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1466 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1467 $rmp->{exit_on_final_map},
1468 $rmp->{xsize}, $rmp->{ysize},
1469 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1470 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1471 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1472 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1473 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1474 (cf::region::find $rmp->{region}), $rmp->{custom}
1475 )
1476}
1477
1478=item cf::map->register ($regex, $prio)
1479
1480Register a handler for the map path matching the given regex at the
1481givne priority (higher is better, built-in handlers have priority 0, the
1482default).
1483
1484=cut
1485
631sub register { 1486sub register {
1487 my (undef, $regex, $prio) = @_;
1488 my $pkg = caller;
1489
1490 no strict;
1491 push @{"$pkg\::ISA"}, __PACKAGE__;
1492
1493 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1494}
1495
1496# also paths starting with '/'
1497$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1498
1499sub thawer_merge {
632 my ($base, $pkg) = @_; 1500 my ($self, $merge) = @_;
633 1501
634 #TODO 1502 # we have to keep some variables in memory intact
635} 1503 local $self->{path};
1504 local $self->{load_path};
636 1505
637sub load_extension { 1506 $self->SUPER::thawer_merge ($merge);
1507}
1508
1509sub normalise {
638 my ($path) = @_; 1510 my ($path, $base) = @_;
639 1511
640 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1512 $path = "$path"; # make sure its a string
641 my $base = $1;
642 my $pkg = $1;
643 $pkg =~ s/[^[:word:]]/_/g;
644 $pkg = "ext::$pkg";
645 1513
646 warn "loading '$path' into '$pkg'\n"; 1514 $path =~ s/\.map$//;
647 1515
648 open my $fh, "<:utf8", $path 1516 # map plan:
649 or die "$path: $!"; 1517 #
1518 # /! non-realised random map exit (special hack!)
1519 # {... are special paths that are not being touched
1520 # ?xxx/... are special absolute paths
1521 # ?random/... random maps
1522 # /... normal maps
1523 # ~user/... per-player map of a specific user
650 1524
651 my $source = 1525 $path =~ s/$PATH_SEP/\//go;
652 "package $pkg; use strict; use utf8;\n"
653 . "#line 1 \"$path\"\n{\n"
654 . (do { local $/; <$fh> })
655 . "\n};\n1";
656 1526
657 eval $source 1527 # treat it as relative path if it starts with
658 or die $@ ? "$path: $@\n" 1528 # something that looks reasonable
659 : "extension disabled.\n"; 1529 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1530 $base or Carp::carp "normalise called with relative path and no base: '$path'";
660 1531
661 push @exts, $pkg; 1532 $base =~ s{[^/]+/?$}{};
662 $ext_pkg{$base} = $pkg; 1533 $path = "$base/$path";
663
664# no strict 'refs';
665# @{"$pkg\::ISA"} = ext::;
666
667 register $base, $pkg;
668}
669
670sub unload_extension {
671 my ($pkg) = @_;
672
673 warn "removing extension $pkg\n";
674
675 # remove hooks
676 #TODO
677# for my $idx (0 .. $#PLUGIN_EVENT) {
678# delete $hook[$idx]{$pkg};
679# } 1534 }
680 1535
681 # remove commands 1536 for ($path) {
682 for my $name (keys %COMMAND) { 1537 redo if s{//}{/};
683 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} }; 1538 redo if s{/\.?/}{/};
1539 redo if s{/[^/]+/\.\./}{/};
1540 }
684 1541
685 if (@cb) { 1542 $path
686 $COMMAND{$name} = \@cb; 1543}
1544
1545sub new_from_path {
1546 my (undef, $path, $base) = @_;
1547
1548 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1549
1550 $path = normalise $path, $base;
1551
1552 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1553 if ($path =~ $EXT_MAP{$pkg}[1]) {
1554 my $self = bless cf::map::new, $pkg;
1555 $self->{path} = $path; $self->path ($path);
1556 $self->init; # pass $1 etc.
1557 return $self;
1558 }
1559 }
1560
1561 Carp::carp "unable to resolve path '$path' (base '$base').";
1562 ()
1563}
1564
1565sub init {
1566 my ($self) = @_;
1567
1568 $self
1569}
1570
1571sub as_string {
1572 my ($self) = @_;
1573
1574 "$self->{path}"
1575}
1576
1577# the displayed name, this is a one way mapping
1578sub visible_name {
1579 &as_string
1580}
1581
1582# the original (read-only) location
1583sub load_path {
1584 my ($self) = @_;
1585
1586 "$MAPDIR/$self->{path}.map"
1587}
1588
1589# the temporary/swap location
1590sub save_path {
1591 my ($self) = @_;
1592
1593 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1594 "$TMPDIR/$path.map"
1595}
1596
1597# the unique path, undef == no special unique path
1598sub uniq_path {
1599 my ($self) = @_;
1600
1601 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1602 "$UNIQUEDIR/$path"
1603}
1604
1605# and all this just because we cannot iterate over
1606# all maps in C++...
1607sub change_all_map_light {
1608 my ($change) = @_;
1609
1610 $_->change_map_light ($change)
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;
1620}
1621
1622sub unlink_save {
1623 my ($self) = @_;
1624
1625 utf8::encode (my $save = $self->save_path);
1626 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1627 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1628}
1629
1630sub load_header_from($) {
1631 my ($self, $path) = @_;
1632
1633 utf8::encode $path;
1634 #aio_open $path, O_RDONLY, 0
1635 # or return;
1636
1637 $self->_load_header ($path)
1638 or return;
1639
1640 $self->{load_path} = $path;
1641
1642 1
1643}
1644
1645sub load_header_orig {
1646 my ($self) = @_;
1647
1648 $self->load_header_from ($self->load_path)
1649}
1650
1651sub load_header_temp {
1652 my ($self) = @_;
1653
1654 $self->load_header_from ($self->save_path)
1655}
1656
1657sub prepare_temp {
1658 my ($self) = @_;
1659
1660 $self->last_access ((delete $self->{last_access})
1661 || $cf::RUNTIME); #d#
1662 # safety
1663 $self->{instantiate_time} = $cf::RUNTIME
1664 if $self->{instantiate_time} > $cf::RUNTIME;
1665}
1666
1667sub prepare_orig {
1668 my ($self) = @_;
1669
1670 $self->{load_original} = 1;
1671 $self->{instantiate_time} = $cf::RUNTIME;
1672 $self->last_access ($cf::RUNTIME);
1673 $self->instantiate;
1674}
1675
1676sub load_header {
1677 my ($self) = @_;
1678
1679 if ($self->load_header_temp) {
1680 $self->prepare_temp;
687 } else { 1681 } else {
688 delete $COMMAND{$name}; 1682 $self->load_header_orig
689 } 1683 or return;
1684 $self->prepare_orig;
1685 }
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
690 } 1693 1
1694}
691 1695
692 # remove extcmds 1696sub find;
693 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) { 1697sub find {
694 delete $EXTCMD{$name}; 1698 my ($path, $origin) = @_;
1699
1700 $path = normalise $path, $origin && $origin->path;
1701
1702 cf::lock_wait "map_find:$path";
1703
1704 $cf::MAP{$path} || do {
1705 my $guard = cf::lock_acquire "map_find:$path";
1706 my $map = new_from_path cf::map $path
1707 or return;
1708
1709 $map->{last_save} = $cf::RUNTIME;
1710
1711 $map->load_header
1712 or return;
1713
1714 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1715 # doing this can freeze the server in a sync job, obviously
1716 #$cf::WAIT_FOR_TICK->wait;
1717 $map->reset;
1718 undef $guard;
1719 return find $path;
1720 }
1721
1722 $cf::MAP{$path} = $map
1723 }
1724}
1725
1726sub pre_load { }
1727sub post_load { }
1728
1729sub load {
1730 my ($self) = @_;
1731
1732 local $self->{deny_reset} = 1; # loading can take a long time
1733
1734 my $path = $self->{path};
1735
695 } 1736 {
1737 my $guard = cf::lock_acquire "map_load:$path";
696 1738
697 if (my $cb = $pkg->can ("unload")) { 1739 return if $self->in_memory != cf::MAP_SWAPPED;
698 eval { 1740
699 $cb->($pkg); 1741 $self->in_memory (cf::MAP_LOADING);
1742
1743 $self->alloc;
1744
1745 $self->pre_load;
1746 Coro::cede;
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);
700 1 1759 }
701 } or warn "$pkg unloaded, but with errors: $@"; 1760 }
702 }
703 1761
704 Symbol::delete_package $pkg; 1762 Coro::cede;
705} 1763 # now do the right thing for maps
1764 $self->link_multipart_objects;
1765 $self->difficulty ($self->estimate_difficulty)
1766 unless $self->difficulty;
1767 Coro::cede;
706 1768
707sub load_extensions { 1769 unless ($self->{deny_activate}) {
708 for my $ext (<$LIBDIR/*.ext>) { 1770 $self->decay_objects;
709 next unless -r $ext; 1771 $self->fix_auto_apply;
710 eval { 1772 $self->update_buttons;
711 load_extension $ext; 1773 Coro::cede;
712 1 1774 $self->set_darkness_map;
713 } or warn "$ext not loaded: $@"; 1775 Coro::cede;
714 } 1776 $self->activate;
715} 1777 }
716 1778
717############################################################################# 1779 $self->in_memory (cf::MAP_IN_MEMORY);
718# load/save/clean perl data associated with a map 1780 }
719 1781
720*cf::mapsupport::on_clean = sub { 1782 $self->post_load;
1783}
1784
1785sub customise_for {
1786 my ($self, $ob) = @_;
1787
1788 return find "~" . $ob->name . "/" . $self->{path}
1789 if $self->per_player;
1790
1791# return find "?party/" . $ob->name . "/" . $self->{path}
1792# if $self->per_party;
1793
1794 $self
1795}
1796
1797# find and load all maps in the 3x3 area around a map
1798sub load_diag {
721 my ($map) = @_; 1799 my ($map) = @_;
722 1800
723 my $path = $map->tmpname; 1801 my @diag; # diagonal neighbours
724 defined $path or return;
725 1802
726 unlink "$path.pst"; 1803 for (0 .. 3) {
727}; 1804 my $neigh = $map->tile_path ($_)
1805 or next;
1806 $neigh = find $neigh, $map
1807 or next;
1808 $neigh->load;
728 1809
729cf::map->attach (prio => -10000, package => cf::mapsupport::); 1810 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1811 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1812 }
730 1813
731############################################################################# 1814 for (@diag) {
732# load/save perl data associated with player->ob objects 1815 my $neigh = find @$_
733 1816 or next;
734sub all_objects(@) { 1817 $neigh->load;
735 @_, map all_objects ($_->inv), @_ 1818 }
736} 1819}
737 1820
738# TODO: compatibility cruft, remove when no longer needed 1821sub find_sync {
739cf::player->attach ( 1822 my ($path, $origin) = @_;
740 on_load => sub {
741 my ($pl, $path) = @_;
742 1823
743 for my $o (all_objects $pl->ob) { 1824 cf::sync_job { find $path, $origin }
744 if (my $value = $o->get_ob_key_value ("_perl_data")) { 1825}
745 $o->set_ob_key_value ("_perl_data");
746 1826
747 %$o = %{ Storable::thaw pack "H*", $value }; 1827sub do_load_sync {
1828 my ($map) = @_;
1829
1830 cf::sync_job { $map->load };
1831}
1832
1833our %MAP_PREFETCH;
1834our $MAP_PREFETCHER = undef;
1835
1836sub find_async {
1837 my ($path, $origin) = @_;
1838
1839 $path = normalise $path, $origin && $origin->{path};
1840
1841 if (my $map = $cf::MAP{$path}) {
1842 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1843 }
1844
1845 undef $MAP_PREFETCH{$path};
1846 $MAP_PREFETCHER ||= cf::async {
1847 while (%MAP_PREFETCH) {
1848 for my $path (keys %MAP_PREFETCH) {
1849 my $map = find $path
1850 or next;
1851 $map->load;
1852
1853 delete $MAP_PREFETCH{$path};
748 } 1854 }
749 } 1855 }
1856 undef $MAP_PREFETCHER;
1857 };
1858 $MAP_PREFETCHER->prio (6);
1859
1860 ()
1861}
1862
1863sub save {
1864 my ($self) = @_;
1865
1866 my $lock = cf::lock_acquire "map_data:" . $self->path;
1867
1868 $self->{last_save} = $cf::RUNTIME;
1869
1870 return unless $self->dirty;
1871
1872 my $save = $self->save_path; utf8::encode $save;
1873 my $uniq = $self->uniq_path; utf8::encode $uniq;
1874
1875 $self->{load_path} = $save;
1876
1877 return if $self->{deny_save};
1878
1879 local $self->{last_access} = $self->last_access;#d#
1880
1881 cf::async {
1882 $_->contr->save for $self->players;
1883 };
1884
1885 if ($uniq) {
1886 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1887 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1888 } else {
1889 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
750 }, 1890 }
751); 1891}
752 1892
753############################################################################# 1893sub swap_out {
1894 my ($self) = @_;
754 1895
755=head2 CORE EXTENSIONS 1896 # save first because save cedes
1897 $self->save;
756 1898
757Functions and methods that extend core crossfire objects. 1899 my $lock = cf::lock_acquire "map_data:" . $self->path;
758 1900
759=head3 cf::player 1901 return if $self->players;
1902 return if $self->in_memory != cf::MAP_IN_MEMORY;
1903 return if $self->{deny_save};
1904
1905 $self->clear;
1906 $self->in_memory (cf::MAP_SWAPPED);
1907}
1908
1909sub reset_at {
1910 my ($self) = @_;
1911
1912 # TODO: safety, remove and allow resettable per-player maps
1913 return 1e99 if $self->{deny_reset};
1914
1915 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1916 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1917
1918 $time + $to
1919}
1920
1921sub should_reset {
1922 my ($self) = @_;
1923
1924 $self->reset_at <= $cf::RUNTIME
1925}
1926
1927sub reset {
1928 my ($self) = @_;
1929
1930 my $lock = cf::lock_acquire "map_data:$self->{path}";
1931
1932 return if $self->players;
1933
1934 warn "resetting map ", $self->path;
1935
1936 $self->in_memory (cf::MAP_SWAPPED);
1937
1938 # need to save uniques path
1939 unless ($self->{deny_save}) {
1940 my $uniq = $self->uniq_path; utf8::encode $uniq;
1941
1942 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1943 if $uniq;
1944 }
1945
1946 delete $cf::MAP{$self->path};
1947
1948 $self->clear;
1949
1950 $_->clear_links_to ($self) for values %cf::MAP;
1951
1952 $self->unlink_save;
1953 $self->destroy;
1954}
1955
1956my $nuke_counter = "aaaa";
1957
1958sub nuke {
1959 my ($self) = @_;
1960
1961 delete $cf::MAP{$self->path};
1962
1963 $self->unlink_save;
1964
1965 bless $self, "cf::map";
1966 delete $self->{deny_reset};
1967 $self->{deny_save} = 1;
1968 $self->reset_timeout (1);
1969 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1970
1971 $cf::MAP{$self->path} = $self;
1972
1973 $self->reset; # polite request, might not happen
1974}
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
2012=item cf::map::unique_maps
2013
2014Returns an arrayref of paths of all shared maps that have
2015instantiated unique items. May block.
2016
2017=cut
2018
2019sub unique_maps() {
2020 [
2021 map {
2022 utf8::decode $_;
2023 /\.map$/
2024 ? normalise $_
2025 : ()
2026 } @{ aio_readdir $UNIQUEDIR or [] }
2027 ]
2028}
2029
2030package cf;
2031
2032=back
2033
2034=head3 cf::object
2035
2036=cut
2037
2038package cf::object;
760 2039
761=over 4 2040=over 4
762 2041
763=item cf::player::exists $login 2042=item $ob->inv_recursive
764 2043
765Returns true when the given account exists. 2044Returns the inventory of the object _and_ their inventories, recursively.
766 2045
767=cut 2046=cut
768 2047
769sub cf::player::exists($) { 2048sub inv_recursive_;
770 cf::player::find $_[0] 2049sub inv_recursive_ {
771 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 2050 map { $_, inv_recursive_ $_->inv } @_
772} 2051}
773 2052
774=item $player->ext_reply ($msgid, $msgtype, %msg) 2053sub inv_recursive {
775 2054 inv_recursive_ inv $_[0]
776Sends an ext reply to the player.
777
778=cut
779
780sub cf::player::ext_reply($$$%) {
781 my ($self, $id, %msg) = @_;
782
783 $msg{msgid} = $id;
784
785 $self->send ("ext " . to_json \%msg);
786} 2055}
2056
2057package cf;
787 2058
788=back 2059=back
789 2060
790=head3 cf::object::player 2061=head3 cf::object::player
791 2062
… …
807 2078
808 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2079 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
809 2080
810 if ($self->{record_replies}) { 2081 if ($self->{record_replies}) {
811 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2082 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2083
812 } 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 {
813 $msg = $npc->name . " says: $msg" if $npc; 2097 $msg = $npc->name . " says: $msg" if $npc;
814 $self->message ($msg, $flags); 2098 $self->message ($msg, $flags);
2099 }
815 } 2100 }
816} 2101}
817 2102
818=item $player_object->may ("access") 2103=item $player_object->may ("access")
819 2104
… …
829 (ref $cf::CFG{"may_$access"} 2114 (ref $cf::CFG{"may_$access"}
830 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 2115 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
831 : $cf::CFG{"may_$access"}) 2116 : $cf::CFG{"may_$access"})
832} 2117}
833 2118
2119=item $player_object->enter_link
2120
2121Freezes the player and moves him/her to a special map (C<{link}>).
2122
2123The player should be reasonably safe there for short amounts of time. You
2124I<MUST> call C<leave_link> as soon as possible, though.
2125
2126Will never block.
2127
2128=item $player_object->leave_link ($map, $x, $y)
2129
2130Moves the player out of the special C<{link}> map onto the specified
2131map. If the map is not valid (or omitted), the player will be moved back
2132to the location he/she was before the call to C<enter_link>, or, if that
2133fails, to the emergency map position.
2134
2135Might block.
2136
2137=cut
2138
2139sub link_map {
2140 unless ($LINK_MAP) {
2141 $LINK_MAP = cf::map::find "{link}"
2142 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2143 $LINK_MAP->load;
2144 }
2145
2146 $LINK_MAP
2147}
2148
2149sub cf::object::player::enter_link {
2150 my ($self) = @_;
2151
2152 $self->deactivate_recursive;
2153
2154 return if UNIVERSAL::isa $self->map, "ext::map_link";
2155
2156 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2157 if $self->map && $self->map->{path} ne "{link}";
2158
2159 $self->enter_map ($LINK_MAP || link_map, 10, 10);
2160}
2161
2162sub cf::object::player::leave_link {
2163 my ($self, $map, $x, $y) = @_;
2164
2165 return unless $self->contr->active;
2166
2167 my $link_pos = delete $self->{_link_pos};
2168
2169 unless ($map) {
2170 # restore original map position
2171 ($map, $x, $y) = @{ $link_pos || [] };
2172 $map = cf::map::find $map;
2173
2174 unless ($map) {
2175 ($map, $x, $y) = @$EMERGENCY_POSITION;
2176 $map = cf::map::find $map
2177 or die "FATAL: cannot load emergency map\n";
2178 }
2179 }
2180
2181 ($x, $y) = (-1, -1)
2182 unless (defined $x) && (defined $y);
2183
2184 # use -1 or undef as default coordinates, not 0, 0
2185 ($x, $y) = ($map->enter_x, $map->enter_y)
2186 if $x <=0 && $y <= 0;
2187
2188 $map->load;
2189 $map->load_diag;
2190
2191 return unless $self->contr->active;
2192 $self->activate_recursive;
2193
2194 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2195 $self->enter_map ($map, $x, $y);
2196}
2197
2198=item $player_object->goto ($path, $x, $y[, $check->($map)])
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
2205=cut
2206
2207our $GOTOGEN;
2208
2209sub cf::object::player::goto {
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;
2214
2215 $self->enter_link;
2216
2217 (async {
2218 my $map = eval {
2219 my $map = cf::map::find $path;
2220
2221 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
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 $@;
2234 }
2235
2236 if ($gen == $self->{_goto_generation}) {
2237 delete $self->{_goto_generation};
2238 $self->leave_link ($map, $x, $y);
2239 }
2240 })->prio (1);
2241}
2242
2243=item $player_object->enter_exit ($exit_object)
2244
2245=cut
2246
2247sub parse_random_map_params {
2248 my ($spec) = @_;
2249
2250 my $rmp = { # defaults
2251 xsize => (cf::rndm 15, 40),
2252 ysize => (cf::rndm 15, 40),
2253 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2254 #layout => string,
2255 };
2256
2257 for (split /\n/, $spec) {
2258 my ($k, $v) = split /\s+/, $_, 2;
2259
2260 $rmp->{lc $k} = $v if (length $k) && (length $v);
2261 }
2262
2263 $rmp
2264}
2265
2266sub prepare_random_map {
2267 my ($exit) = @_;
2268
2269 my $guard = cf::lock_acquire "exit_prepare:$exit";
2270
2271 # all this does is basically replace the /! path by
2272 # a new random map path (?random/...) with a seed
2273 # that depends on the exit object
2274
2275 my $rmp = parse_random_map_params $exit->msg;
2276
2277 if ($exit->map) {
2278 $rmp->{region} = $exit->region->name;
2279 $rmp->{origin_map} = $exit->map->path;
2280 $rmp->{origin_x} = $exit->x;
2281 $rmp->{origin_y} = $exit->y;
2282 }
2283
2284 $rmp->{random_seed} ||= $exit->random_seed;
2285
2286 my $data = cf::to_json $rmp;
2287 my $md5 = Digest::MD5::md5_hex $data;
2288 my $meta = "$RANDOMDIR/$md5.meta";
2289
2290 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2291 aio_write $fh, 0, (length $data), $data, 0;
2292 undef $fh;
2293 aio_rename "$meta~", $meta;
2294
2295 $exit->slaying ("?random/$md5");
2296 $exit->msg (undef);
2297 }
2298}
2299
2300sub cf::object::player::enter_exit {
2301 my ($self, $exit) = @_;
2302
2303 return unless $self->type == cf::PLAYER;
2304
2305 if ($exit->slaying eq "/!") {
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
2309 cf::sync_job { prepare_random_map $exit };
2310 }
2311
2312 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2313 my $hp = $exit->stats->hp;
2314 my $sp = $exit->stats->sp;
2315
2316 $self->enter_link;
2317
2318 (async {
2319 $self->deactivate_recursive; # just to be sure
2320 unless (eval {
2321 $self->goto ($slaying, $hp, $sp);
2322
2323 1;
2324 }) {
2325 $self->message ("Something went wrong deep within the crossfire server. "
2326 . "I'll try to bring you back to the map you were before. "
2327 . "Please report this to the dungeon master!",
2328 cf::NDI_UNIQUE | cf::NDI_RED);
2329
2330 warn "ERROR in enter_exit: $@";
2331 $self->leave_link;
2332 }
2333 })->prio (1);
2334}
2335
834=head3 cf::client 2336=head3 cf::client
835 2337
836=over 4 2338=over 4
837 2339
838=item $client->send_drawinfo ($text, $flags) 2340=item $client->send_drawinfo ($text, $flags)
… …
844 2346
845sub cf::client::send_drawinfo { 2347sub cf::client::send_drawinfo {
846 my ($self, $text, $flags) = @_; 2348 my ($self, $text, $flags) = @_;
847 2349
848 utf8::encode $text; 2350 utf8::encode $text;
849 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2351 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
850} 2352}
851 2353
2354=item $client->send_msg ($color, $type, $msg, [extra...])
2355
2356Send a drawinfo or msg packet to the client, formatting the msg for the
2357client if neccessary. C<$type> should be a string identifying the type of
2358the message, with C<log> being the default. If C<$color> is negative, suppress
2359the message unless the client supports the msg packet.
2360
2361=cut
2362
2363sub cf::client::send_msg {
2364 my ($self, $color, $type, $msg, @extra) = @_;
2365
2366 $msg = $self->pl->expand_cfpod ($msg);
2367
2368 if ($self->can_msg) {
2369 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2370 } else {
2371 # replace some tags by gcfclient-compatible ones
2372 for ($msg) {
2373 1 while
2374 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2375 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2376 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2377 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2378 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${1}[\/color]/;
2379 }
2380
2381 if ($color >= 0) {
2382 if (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}
852 2404
853=item $success = $client->query ($flags, "text", \&cb) 2405=item $success = $client->query ($flags, "text", \&cb)
854 2406
855Queues a query to the client, calling the given callback with 2407Queues a query to the client, calling the given callback with
856the 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>,
… …
881 on_reply => sub { 2433 on_reply => sub {
882 my ($ns, $msg) = @_; 2434 my ($ns, $msg) = @_;
883 2435
884 # this weird shuffling is so that direct followup queries 2436 # this weird shuffling is so that direct followup queries
885 # get handled first 2437 # get handled first
886 my $queue = delete $ns->{query_queue}; 2438 my $queue = delete $ns->{query_queue}
2439 or return; # be conservative, not sure how that can happen, but we saw a crash here
887 2440
888 (shift @$queue)->[1]->($msg); 2441 (shift @$queue)->[1]->($msg);
2442 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
889 2443
890 push @{ $ns->{query_queue} }, @$queue; 2444 push @{ $ns->{query_queue} }, @$queue;
891 2445
892 if (@{ $ns->{query_queue} } == @$queue) { 2446 if (@{ $ns->{query_queue} } == @$queue) {
893 if (@$queue) { 2447 if (@$queue) {
… …
897 } 2451 }
898 } 2452 }
899 }, 2453 },
900); 2454);
901 2455
902=item $client->coro (\&cb) 2456=item $client->async (\&cb)
903 2457
904Create a new coroutine, running the specified callback. The coroutine will 2458Create a new coroutine, running the specified callback. The coroutine will
905be automatically cancelled when the client gets destroyed (e.g. on logout, 2459be automatically cancelled when the client gets destroyed (e.g. on logout,
906or loss of connection). 2460or loss of connection).
907 2461
908=cut 2462=cut
909 2463
910sub cf::client::coro { 2464sub cf::client::async {
911 my ($self, $cb) = @_; 2465 my ($self, $cb) = @_;
912 2466
913 my $coro; $coro = async { 2467 my $coro = &Coro::async ($cb);
914 eval { 2468
915 $cb->(); 2469 $coro->on_destroy (sub {
916 };
917 warn $@ if $@;
918 delete $self->{_coro}{$coro+0}; 2470 delete $self->{_coro}{$coro+0};
919 }; 2471 });
920 2472
921 $self->{_coro}{$coro+0} = $coro; 2473 $self->{_coro}{$coro+0} = $coro;
2474
2475 $coro
922} 2476}
923 2477
924cf::client->attach ( 2478cf::client->attach (
925 on_destroy => sub { 2479 on_destroy => sub {
926 my ($ns) = @_; 2480 my ($ns) = @_;
… …
951 2505
952# here we export the classes and methods available to script code 2506# here we export the classes and methods available to script code
953 2507
954=pod 2508=pod
955 2509
956The following fucntions and emthods are available within a safe environment: 2510The following functions and methods are available within a safe environment:
957 2511
958 cf::object contr pay_amount pay_player map 2512 cf::object contr pay_amount pay_player map
959 cf::object::player player 2513 cf::object::player player
960 cf::player peaceful 2514 cf::player peaceful
961 cf::map trigger 2515 cf::map trigger
… …
1042=back 2596=back
1043 2597
1044=cut 2598=cut
1045 2599
1046############################################################################# 2600#############################################################################
2601# the server's init and main functions
1047 2602
1048=head2 EXTENSION DATABASE SUPPORT 2603sub load_facedata($) {
2604 my ($path) = @_;
1049 2605
1050Crossfire maintains a very simple database for extension use. It can 2606 warn "loading facedata from $path\n";
1051currently store anything that can be serialised using Storable, which
1052excludes objects.
1053 2607
1054The parameter C<$family> should best start with the name of the extension 2608 my $facedata;
1055using it, it should be unique. 2609 0 < aio_load $path, $facedata
2610 or die "$path: $!";
1056 2611
1057=over 4 2612 $facedata = Coro::Storable::thaw $facedata;
1058 2613
1059=item $hashref = cf::db_get $family 2614 $facedata->{version} == 2
2615 or cf::cleanup "$path: version mismatch, cannot proceed.";
1060 2616
1061Return a hashref for use by the extension C<$family>, which can be
1062modified. After modifications, you have to call C<cf::db_dirty> or
1063C<cf::db_sync>.
1064
1065=item $value = cf::db_get $family => $key
1066
1067Returns a single value from the database
1068
1069=item cf::db_put $family => $hashref
1070
1071Stores the given family hashref into the database. Updates are delayed, if
1072you want the data to be synced to disk immediately, use C<cf::db_sync>.
1073
1074=item cf::db_put $family => $key => $value
1075
1076Stores the given C<$value> in the family hash. Updates are delayed, if you
1077want the data to be synced to disk immediately, use C<cf::db_sync>.
1078
1079=item cf::db_dirty
1080
1081Marks the database as dirty, to be updated at a later time.
1082
1083=item cf::db_sync
1084
1085Immediately write the database to disk I<if it is dirty>.
1086
1087=cut
1088
1089our $DB;
1090
1091{
1092 my $path = cf::localdir . "/database.pst";
1093
1094 sub db_load() {
1095 warn "loading database $path\n";#d# remove later
1096 $DB = stat $path ? Storable::retrieve $path : { };
1097 } 2617 {
2618 my $faces = $facedata->{faceinfo};
1098 2619
1099 my $pid; 2620 while (my ($face, $info) = each %$faces) {
1100 2621 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1101 sub db_save() { 2622 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
1102 warn "saving database $path\n";#d# remove later 2623 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
1103 waitpid $pid, 0 if $pid; 2624 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
1104 if (0 == ($pid = fork)) { 2625 Coro::cede;
1105 $DB->{_meta}{version} = 1;
1106 Storable::nstore $DB, "$path~";
1107 rename "$path~", $path;
1108 cf::_exit 0 if defined $pid;
1109 }
1110 }
1111
1112 my $dirty;
1113
1114 sub db_sync() {
1115 db_save if $dirty;
1116 undef $dirty;
1117 }
1118
1119 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1120 db_sync;
1121 });
1122
1123 sub db_dirty() {
1124 $dirty = 1;
1125 $idle->start;
1126 }
1127
1128 sub db_get($;$) {
1129 @_ >= 2
1130 ? $DB->{$_[0]}{$_[1]}
1131 : ($DB->{$_[0]} ||= { })
1132 }
1133
1134 sub db_put($$;$) {
1135 if (@_ >= 3) {
1136 $DB->{$_[0]}{$_[1]} = $_[2];
1137 } else {
1138 $DB->{$_[0]} = $_[1];
1139 }
1140 db_dirty;
1141 }
1142
1143 cf::global->attach (
1144 prio => 10000,
1145 on_cleanup => sub {
1146 db_sync;
1147 }, 2626 }
1148 );
1149}
1150 2627
1151############################################################################# 2628 while (my ($face, $info) = each %$faces) {
1152# the server's main() 2629 next unless $info->{smooth};
2630 my $idx = cf::face::find $face
2631 or next;
2632 if (my $smooth = cf::face::find $info->{smooth}) {
2633 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2634 } else {
2635 warn "smooth face '$info->{smooth}' not found for face '$face'";
2636 }
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
2650 }
2651
2652 1
2653}
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
2675sub reload_resources {
2676 warn "reloading resource files...\n";
2677
2678 reload_regions;
2679 reload_facedata;
2680 #reload_archetypes;#d#
2681 reload_archetypes;
2682 reload_treasures;
2683
2684 warn "finished reloading resource files\n";
2685}
2686
2687sub init {
2688 reload_resources;
2689}
1153 2690
1154sub cfg_load { 2691sub cfg_load {
1155 open my $fh, "<:utf8", cf::confdir . "/config" 2692 open my $fh, "<:utf8", "$CONFDIR/config"
1156 or return; 2693 or return;
1157 2694
1158 local $/; 2695 local $/;
1159 *CFG = YAML::Syck::Load <$fh>; 2696 *CFG = YAML::Syck::Load <$fh>;
2697
2698 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2699
2700 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2701 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2702
2703 if (exists $CFG{mlockall}) {
2704 eval {
2705 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2706 and die "WARNING: m(un)lockall failed: $!\n";
2707 };
2708 warn $@ if $@;
2709 }
1160} 2710}
1161 2711
1162sub main { 2712sub main {
2713 # we must not ever block the main coroutine
2714 local $Coro::idle = sub {
2715 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2716 (async {
2717 Event::one_event;
2718 })->prio (Coro::PRIO_MAX);
2719 };
2720
1163 cfg_load; 2721 cfg_load;
1164 db_load; 2722 db_init;
1165 load_extensions; 2723 load_extensions;
2724
2725 $TICK_WATCHER->start;
1166 Event::loop; 2726 Event::loop;
1167} 2727}
1168 2728
1169############################################################################# 2729#############################################################################
1170# initialisation 2730# initialisation and cleanup
1171 2731
1172sub _perl_reload(&) { 2732# install some emergency cleanup handlers
2733BEGIN {
2734 for my $signal (qw(INT HUP TERM)) {
2735 Event->signal (
2736 reentrant => 0,
2737 data => WF_AUTOCANCEL,
2738 signal => $signal,
2739 prio => 0,
2740 cb => sub {
2741 cf::cleanup "SIG$signal";
2742 },
2743 );
2744 }
2745}
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
2785sub emergency_save() {
2786 my $freeze_guard = cf::freeze_mainloop;
2787
2788 warn "enter emergency perl save\n";
2789
2790 cf::sync_job {
2791 # use a peculiar iteration method to avoid tripping on perl
2792 # refcount bugs in for. also avoids problems with players
2793 # and maps saved/destroyed asynchronously.
2794 warn "begin emergency player save\n";
2795 for my $login (keys %cf::PLAYER) {
2796 my $pl = $cf::PLAYER{$login} or next;
2797 $pl->valid or next;
2798 $pl->save;
2799 }
2800 warn "end emergency player save\n";
2801
2802 warn "begin emergency map save\n";
2803 for my $path (keys %cf::MAP) {
2804 my $map = $cf::MAP{$path} or next;
2805 $map->valid or next;
2806 $map->save;
2807 }
2808 warn "end emergency map save\n";
2809
2810 warn "begin emergency database checkpoint\n";
2811 BDB::db_env_txn_checkpoint $DB_ENV;
2812 warn "end emergency database checkpoint\n";
2813 };
2814
2815 warn "leave emergency perl save\n";
2816}
2817
2818sub post_cleanup {
1173 my ($msg) = @_; 2819 my ($make_core) = @_;
1174 2820
1175 $msg->("reloading..."); 2821 warn Carp::longmess "post_cleanup backtrace"
2822 if $make_core;
2823}
1176 2824
1177 eval { 2825sub do_reload_perl() {
1178 # cancel all watchers 2826 # can/must only be called in main
2827 if ($Coro::current != $Coro::main) {
2828 warn "can only reload from main coroutine";
2829 return;
2830 }
2831
2832 warn "reloading...";
2833
2834 warn "entering sync_job";
2835
2836 cf::sync_job {
2837 cf::write_runtime; # external watchdog should not bark
2838 cf::emergency_save;
2839 cf::write_runtime; # external watchdog should not bark
2840
2841 warn "syncing database to disk";
2842 BDB::db_env_txn_checkpoint $DB_ENV;
2843
2844 # if anything goes wrong in here, we should simply crash as we already saved
2845
2846 warn "cancelling all WF_AUTOCANCEL watchers";
1179 for (Event::all_watchers) { 2847 for (Event::all_watchers) {
1180 $_->cancel if $_->data & WF_AUTOCANCEL; 2848 $_->cancel if $_->data & WF_AUTOCANCEL;
1181 } 2849 }
1182 2850
1183 # unload all extensions 2851 warn "flushing outstanding aio requests";
1184 for (@exts) { 2852 for (;;) {
1185 $msg->("unloading <$_>"); 2853 BDB::flush;
1186 unload_extension $_; 2854 IO::AIO::flush;
2855 Coro::cede;
2856 last unless IO::AIO::nreqs || BDB::nreqs;
2857 warn "iterate...";
2858 }
2859
2860 ++$RELOAD;
2861
2862 warn "cancelling all extension coros";
2863 $_->cancel for values %EXT_CORO;
2864 %EXT_CORO = ();
2865
2866 warn "removing commands";
2867 %COMMAND = ();
2868
2869 warn "removing ext commands";
2870 %EXTCMD = ();
2871
2872 warn "unloading/nuking all extensions";
2873 for my $pkg (@EXTS) {
2874 warn "... unloading $pkg";
2875
2876 if (my $cb = $pkg->can ("unload")) {
2877 eval {
2878 $cb->($pkg);
2879 1
2880 } or warn "$pkg unloaded, but with errors: $@";
1187 } 2881 }
1188 2882
2883 warn "... nuking $pkg";
2884 Symbol::delete_package $pkg;
2885 }
2886
1189 # unload all modules loaded from $LIBDIR 2887 warn "unloading all perl modules loaded from $LIBDIR";
1190 while (my ($k, $v) = each %INC) { 2888 while (my ($k, $v) = each %INC) {
1191 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2889 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
1192 2890
1193 $msg->("removing <$k>"); 2891 warn "... unloading $k";
1194 delete $INC{$k}; 2892 delete $INC{$k};
1195 2893
1196 $k =~ s/\.pm$//; 2894 $k =~ s/\.pm$//;
1197 $k =~ s/\//::/g; 2895 $k =~ s/\//::/g;
1198 2896
… …
1201 } 2899 }
1202 2900
1203 Symbol::delete_package $k; 2901 Symbol::delete_package $k;
1204 } 2902 }
1205 2903
1206 # sync database to disk
1207 cf::db_sync;
1208
1209 # get rid of safe::, as good as possible 2904 warn "getting rid of safe::, as good as possible";
1210 Symbol::delete_package "safe::$_" 2905 Symbol::delete_package "safe::$_"
1211 for qw(cf::object cf::object::player 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);
1212 2907
1213 # remove register_script_function callbacks
1214 # TODO
1215
1216 # unload cf.pm "a bit" 2908 warn "unloading cf.pm \"a bit\"";
1217 delete $INC{"cf.pm"}; 2909 delete $INC{"cf.pm"};
2910 delete $INC{"cf/pod.pm"};
1218 2911
1219 # don't, removes xs symbols, too, 2912 # don't, removes xs symbols, too,
1220 # and global variables created in xs 2913 # and global variables created in xs
1221 #Symbol::delete_package __PACKAGE__; 2914 #Symbol::delete_package __PACKAGE__;
1222 2915
1223 # reload cf.pm 2916 warn "unload completed, starting to reload now";
2917
1224 $msg->("reloading cf.pm"); 2918 warn "reloading cf.pm";
1225 require cf; 2919 require cf;
1226 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2920 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
1227 2921
1228
1229 # load config and database again 2922 warn "loading config and database again";
1230 cf::cfg_load; 2923 cf::cfg_load;
1231 cf::db_load;
1232 2924
1233 # load extensions 2925 warn "loading extensions";
1234 $msg->("load extensions");
1235 cf::load_extensions; 2926 cf::load_extensions;
1236 2927
1237 # reattach attachments to objects 2928 warn "reattaching attachments to objects/players";
1238 $msg->("reattach"); 2929 _global_reattach; # objects, sockets
1239 _global_reattach; 2930 warn "reattaching attachments to maps";
2931 reattach $_ for values %MAP;
2932 warn "reattaching attachments to players";
2933 reattach $_ for values %PLAYER;
2934
2935 warn "leaving sync_job";
2936
2937 1
2938 } or do {
2939 warn $@;
2940 warn "error while reloading, exiting.";
2941 exit 1;
1240 }; 2942 };
1241 $msg->($@) if $@;
1242 2943
1243 $msg->("reloaded"); 2944 warn "reloaded";
1244}; 2945};
1245 2946
1246sub perl_reload() { 2947our $RELOAD_WATCHER; # used only during reload
1247 _perl_reload { 2948
1248 warn $_[0]; 2949sub reload_perl() {
1249 print "$_[0]\n"; 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 },
1250 }; 2961 );
1251} 2962}
1252 2963
1253register "<global>", __PACKAGE__;
1254
1255register_command "perl-reload" => sub { 2964register_command "reload" => sub {
1256 my ($who, $arg) = @_; 2965 my ($who, $arg) = @_;
1257 2966
1258 if ($who->flag (FLAG_WIZ)) { 2967 if ($who->flag (FLAG_WIZ)) {
1259 _perl_reload { 2968 $who->message ("reloading server.");
1260 warn $_[0]; 2969 async { reload_perl };
1261 $who->message ($_[0]); 2970 }
2971};
2972
2973unshift @INC, $LIBDIR;
2974
2975my $bug_warning = 0;
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;
3000$TICK_WATCHER = Event->timer (
3001 reentrant => 0,
3002 parked => 1,
3003 prio => 0,
3004 at => $NEXT_TICK || $TICK,
3005 data => WF_AUTOCANCEL,
3006 cb => sub {
3007 if ($Coro::current != $Coro::main) {
3008 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3009 unless ++$bug_warning > 10;
3010 return;
3011 }
3012
3013 $NOW = $tick_start = Event::time;
3014
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
1262 }; 3038 };
1263 }
1264};
1265 3039
1266unshift @INC, $LIBDIR; 3040 $RUNTIME += $TICK;
1267
1268$TICK_WATCHER = Event->timer (
1269 prio => 0,
1270 at => $NEXT_TICK || 1,
1271 data => WF_AUTOCANCEL,
1272 cb => sub {
1273 cf::server_tick; # one server iteration
1274
1275 my $NOW = Event::time;
1276 $NEXT_TICK += $TICK; 3041 $NEXT_TICK += $TICK;
3042
3043 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3044 $NEXT_RUNTIME_WRITE = $NOW + 10;
3045 Coro::async_pool {
3046 write_runtime
3047 or warn "ERROR: unable to write runtime file: $!";
3048 };
3049 }
3050
3051# my $AFTER = Event::time;
3052# warn $AFTER - $NOW;#d#
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;
1277 3062
1278 # 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
1279 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4; 3064 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
1280 3065
1281 $TICK_WATCHER->at ($NEXT_TICK); 3066 $TICK_WATCHER->at ($NEXT_TICK);
1282 $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
1283 }, 3075 },
1284); 3076);
1285 3077
3078{
3079 BDB::max_poll_time $TICK * 0.1;
3080 $BDB_POLL_WATCHER = Event->io (
3081 reentrant => 0,
3082 fd => BDB::poll_fileno,
3083 poll => 'r',
3084 prio => 0,
3085 data => WF_AUTOCANCEL,
3086 cb => \&BDB::poll_cb,
3087 );
3088 BDB::min_parallel 8;
3089
3090 BDB::set_sync_prepare {
3091 my $status;
3092 my $current = $Coro::current;
3093 (
3094 sub {
3095 $status = $!;
3096 $current->ready; undef $current;
3097 },
3098 sub {
3099 Coro::schedule while defined $current;
3100 $! = $status;
3101 },
3102 )
3103 };
3104
3105 unless ($DB_ENV) {
3106 $DB_ENV = BDB::db_env_create;
3107
3108 cf::sync_job {
3109 eval {
3110 BDB::db_env_open
3111 $DB_ENV,
3112 $BDBDIR,
3113 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3114 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3115 0666;
3116
3117 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3118
3119 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3120 $DB_ENV->set_lk_detect;
3121 };
3122
3123 cf::cleanup "db_env_open(db): $@" if $@;
3124 };
3125 }
3126}
3127
3128{
3129 IO::AIO::min_parallel 8;
3130
3131 undef $Coro::AIO::WATCHER;
1286IO::AIO::max_poll_time $TICK * 0.2; 3132 IO::AIO::max_poll_time $TICK * 0.1;
1287 3133 $AIO_POLL_WATCHER = Event->io (
1288Event->io (fd => IO::AIO::poll_fileno, 3134 reentrant => 0,
1289 poll => 'r',
1290 prio => 5,
1291 data => WF_AUTOCANCEL, 3135 data => WF_AUTOCANCEL,
3136 fd => IO::AIO::poll_fileno,
3137 poll => 'r',
3138 prio => 6,
1292 cb => \&IO::AIO::poll_cb); 3139 cb => \&IO::AIO::poll_cb,
3140 );
3141}
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
3184END { cf::emergency_save }
1293 3185
12941 31861
1295 3187

Diff Legend

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