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.122 by root, Tue Jan 2 17:32:24 2007 UTC vs.
Revision 1.287 by root, Mon Jun 25 05:43:45 2007 UTC

3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
10use Event;
9use Opcode; 11use Opcode;
10use Safe; 12use Safe;
11use Safe::Hole; 13use Safe::Hole;
12 14
13use Coro 3.3; 15use Coro 3.61 ();
16use Coro::State;
17use Coro::Handle;
14use Coro::Event; 18use Coro::Event;
15use Coro::Timer; 19use Coro::Timer;
16use Coro::Signal; 20use Coro::Signal;
17use Coro::Semaphore; 21use Coro::Semaphore;
18use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
19 24
25use BDB ();
26use Data::Dumper;
20use Digest::MD5; 27use Digest::MD5;
21use Fcntl; 28use Fcntl;
22use IO::AIO 2.31 ();
23use YAML::Syck (); 29use YAML::Syck ();
30use IO::AIO 2.32 ();
24use Time::HiRes; 31use Time::HiRes;
32use Compress::LZF;
25 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
26use 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
27 41
28# 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?
29$YAML::Syck::ImplicitUnicode = 1; 43$YAML::Syck::ImplicitUnicode = 1;
30 44
31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32 46
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 48
35our %COMMAND = (); 49our %COMMAND = ();
36our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
51
52our @EXTS = (); # list of extension package names
37our %EXTCMD = (); 53our %EXTCMD = ();
54our %EXTICMD = ();
55our %EXT_CORO = (); # coroutines bound to extensions
56our %EXT_MAP = (); # pluggable maps
38 57
58our $RELOAD; # number of reloads so far
39our @EVENT; 59our @EVENT;
40our $LIBDIR = datadir . "/ext";
41 60
42our $TICK = MAX_TIME * 1e-6; 61our $CONFDIR = confdir;
62our $DATADIR = datadir;
63our $LIBDIR = "$DATADIR/ext";
64our $PODDIR = "$DATADIR/pod";
65our $MAPDIR = "$DATADIR/" . mapdir;
66our $LOCALDIR = localdir;
67our $TMPDIR = "$LOCALDIR/" . tmpdir;
68our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
69our $PLAYERDIR = "$LOCALDIR/" . playerdir;
70our $RANDOMDIR = "$LOCALDIR/random";
71our $BDBDIR = "$LOCALDIR/db";
72
73our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
43our $TICK_WATCHER; 74our $TICK_WATCHER;
75our $AIO_POLL_WATCHER;
76our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
44our $NEXT_TICK; 77our $NEXT_TICK;
45our $NOW; 78our $NOW;
79our $USE_FSYNC = 1; # use fsync to write maps - default off
80
81our $BDB_POLL_WATCHER;
82our $DB_ENV;
46 83
47our %CFG; 84our %CFG;
48 85
49our $UPTIME; $UPTIME ||= time; 86our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 87our $RUNTIME;
51 88
89our %PLAYER; # all users
52our %MAP; # all maps 90our %MAP; # all maps
53our $LINK_MAP; # the special {link} map 91our $LINK_MAP; # the special {link} map, which is always available
54our $FREEZE; 92
55our $RANDOM_MAPS = cf::localdir . "/random"; 93# used to convert map paths into valid unix filenames by replacing / by ∕
56our %EXT_CORO; 94our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
95
96our $LOAD; # a number between 0 (idle) and 1 (too many objects)
97our $LOADAVG; # same thing, but with alpha-smoothing
98our $tick_start; # for load detecting purposes
57 99
58binmode STDOUT; 100binmode STDOUT;
59binmode STDERR; 101binmode STDERR;
60 102
61# read virtual server time, if available 103# read virtual server time, if available
62unless ($RUNTIME || !-e cf::localdir . "/runtime") { 104unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
63 open my $fh, "<", cf::localdir . "/runtime" 105 open my $fh, "<", "$LOCALDIR/runtime"
64 or die "unable to read runtime file: $!"; 106 or die "unable to read runtime file: $!";
65 $RUNTIME = <$fh> + 0.; 107 $RUNTIME = <$fh> + 0.;
66} 108}
67 109
68mkdir cf::localdir; 110mkdir $_
69mkdir cf::localdir . "/" . cf::playerdir; 111 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
70mkdir cf::localdir . "/" . cf::tmpdir;
71mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS;
73 112
74# a special map that is always available 113our $EMERGENCY_POSITION;
75our $LINK_MAP;
76 114
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 115sub cf::map::normalise;
78 116
79############################################################################# 117#############################################################################
80 118
81=head2 GLOBAL VARIABLES 119=head2 GLOBAL VARIABLES
82 120
89=item $cf::RUNTIME 127=item $cf::RUNTIME
90 128
91The time this server has run, starts at 0 and is increased by $cf::TICK on 129The time this server has run, starts at 0 and is increased by $cf::TICK on
92every server tick. 130every server tick.
93 131
94=item $cf::LIBDIR 132=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
133$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
134$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
95 135
96The perl library directory, where extensions and cf-specific modules can 136Various directories - "/etc", read-only install directory, perl-library
97be found. It will be added to C<@INC> automatically. 137directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
138unique-items directory, player file directory, random maps directory and
139database environment.
98 140
99=item $cf::NOW 141=item $cf::NOW
100 142
101The time of the last (current) server tick. 143The time of the last (current) server tick.
102 144
103=item $cf::TICK 145=item $cf::TICK
104 146
105The interval between server ticks, in seconds. 147The interval between server ticks, in seconds.
148
149=item $cf::LOADAVG
150
151The current CPU load on the server (alpha-smoothed), as a value between 0
152(none) and 1 (overloaded), indicating how much time is spent on processing
153objects per tick. Healthy values are < 0.5.
154
155=item $cf::LOAD
156
157The raw value load value from the last tick.
106 158
107=item %cf::CFG 159=item %cf::CFG
108 160
109Configuration for the server, loaded from C</etc/crossfire/config>, or 161Configuration for the server, loaded from C</etc/crossfire/config>, or
110from wherever your confdir points to. 162from wherever your confdir points to.
163
164=item cf::wait_for_tick, cf::wait_for_tick_begin
165
166These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
167returns directly I<after> the tick processing (and consequently, can only wake one process
168per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
111 169
112=back 170=back
113 171
114=cut 172=cut
115 173
116BEGIN { 174BEGIN {
117 *CORE::GLOBAL::warn = sub { 175 *CORE::GLOBAL::warn = sub {
118 my $msg = join "", @_; 176 my $msg = join "", @_;
119 utf8::encode $msg;
120 177
121 $msg .= "\n" 178 $msg .= "\n"
122 unless $msg =~ /\n$/; 179 unless $msg =~ /\n$/;
123 180
181 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
182
183 utf8::encode $msg;
124 LOG llevError, "cfperl: $msg"; 184 LOG llevError, $msg;
125 }; 185 };
126} 186}
127 187
128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 188@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
129@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 189@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
130@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 190@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
131@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 191@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
132@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 192@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
193@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
133@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 194@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
134 195
135# we bless all objects into (empty) derived classes to force a method lookup 196# we bless all objects into (empty) derived classes to force a method lookup
136# within the Safe compartment. 197# within the Safe compartment.
137for my $pkg (qw( 198for my $pkg (qw(
138 cf::global cf::attachable 199 cf::global cf::attachable
147 208
148$Event::DIED = sub { 209$Event::DIED = sub {
149 warn "error in event callback: @_"; 210 warn "error in event callback: @_";
150}; 211};
151 212
152my %ext_pkg; 213#############################################################################
153my @exts;
154my @hook;
155 214
156=head2 UTILITY FUNCTIONS 215=head2 UTILITY FUNCTIONS
157 216
158=over 4 217=over 4
159 218
160=cut 219=item dumpval $ref
161 220
162use JSON::Syck (); # TODO# replace by JSON::PC once working 221=cut
222
223sub dumpval {
224 eval {
225 local $SIG{__DIE__};
226 my $d;
227 if (1) {
228 $d = new Data::Dumper([$_[0]], ["*var"]);
229 $d->Terse(1);
230 $d->Indent(2);
231 $d->Quotekeys(0);
232 $d->Useqq(1);
233 #$d->Bless(...);
234 $d->Seen($_[1]) if @_ > 1;
235 $d = $d->Dump();
236 }
237 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
238 $d
239 } || "[unable to dump $_[0]: '$@']";
240}
241
242use JSON::XS ();
163 243
164=item $ref = cf::from_json $json 244=item $ref = cf::from_json $json
165 245
166Converts a JSON string into the corresponding perl data structure. 246Converts a JSON string into the corresponding perl data structure.
167 247
168=cut
169
170sub from_json($) {
171 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
172 JSON::Syck::Load $_[0]
173}
174
175=item $json = cf::to_json $ref 248=item $json = cf::to_json $ref
176 249
177Converts a perl data structure into its JSON representation. 250Converts a perl data structure into its JSON representation.
178 251
179=cut 252=cut
180 253
181sub to_json($) { 254our $json_coder = JSON::XS->new->convert_blessed->utf8;
182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
183 JSON::Syck::Dump $_[0]
184}
185 255
186=item my $guard = cf::guard { BLOCK } 256sub to_json ($) { $json_coder->encode ($_[0]) }
187 257sub from_json ($) { $json_coder->decode ($_[0]) }
188Run the given callback when the guard object gets destroyed (useful for
189coroutine cancellations).
190
191You can call C<< ->cancel >> on the guard object to stop the block from
192being executed.
193
194=cut
195
196sub guard(&) {
197 bless \(my $cb = $_[0]), cf::guard::;
198}
199
200sub cf::guard::cancel {
201 ${$_[0]} = sub { };
202}
203
204sub cf::guard::DESTROY {
205 ${$_[0]}->();
206}
207 258
208=item cf::lock_wait $string 259=item cf::lock_wait $string
209 260
210Wait until the given lock is available. See cf::lock_acquire. 261Wait until the given lock is available. See cf::lock_acquire.
211 262
212=item my $lock = cf::lock_acquire $string 263=item my $lock = cf::lock_acquire $string
213 264
214Wait until the given lock is available and then acquires it and returns 265Wait until the given lock is available and then acquires it and returns
215a guard object. If the guard object gets destroyed (goes out of scope, 266a Coro::guard object. If the guard object gets destroyed (goes out of scope,
216for example when the coroutine gets canceled), the lock is automatically 267for example when the coroutine gets canceled), the lock is automatically
217returned. 268returned.
218 269
219Lock names should begin with a unique identifier (for example, find_map 270Lock names should begin with a unique identifier (for example, cf::map::find
220uses map_find and load_map uses map_load). 271uses map_find and cf::map::load uses map_load).
272
273=item $locked = cf::lock_active $string
274
275Return true if the lock is currently active, i.e. somebody has locked it.
221 276
222=cut 277=cut
223 278
224our %LOCK; 279our %LOCK;
225 280
239 # wait, to be sure we are not locked 294 # wait, to be sure we are not locked
240 lock_wait $key; 295 lock_wait $key;
241 296
242 $LOCK{$key} = []; 297 $LOCK{$key} = [];
243 298
244 cf::guard { 299 Coro::guard {
245 # wake up all waiters, to be on the safe side 300 # wake up all waiters, to be on the safe side
246 $_->ready for @{ delete $LOCK{$key} }; 301 $_->ready for @{ delete $LOCK{$key} };
247 } 302 }
248} 303}
249 304
305sub lock_active($) {
306 my ($key) = @_;
307
308 ! ! $LOCK{$key}
309}
310
311sub freeze_mainloop {
312 return unless $TICK_WATCHER->is_active;
313
314 my $guard = Coro::guard {
315 $TICK_WATCHER->start;
316 };
317 $TICK_WATCHER->stop;
318 $guard
319}
320
321=item cf::async { BLOCK }
322
323Currently the same as Coro::async_pool, meaning you cannot use
324C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
325thing you are allowed to do is call C<prio> on it.
326
327=cut
328
329BEGIN { *async = \&Coro::async_pool }
330
250=item cf::sync_job { BLOCK } 331=item cf::sync_job { BLOCK }
251 332
252The design of crossfire+ requires that the main coro ($Coro::main) is 333The design of Crossfire TRT requires that the main coroutine ($Coro::main)
253always able to handle events or runnable, as crossfire+ is only partly 334is always able to handle events or runnable, as Crossfire TRT is only
254reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 335partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
336acceptable.
255 337
256If it must be done, put the blocking parts into C<sync_job>. This will run 338If it must be done, put the blocking parts into C<sync_job>. This will run
257the given BLOCK in another coroutine while waiting for the result. The 339the given BLOCK in another coroutine while waiting for the result. The
258server will be frozen during this time, so the block should either finish 340server will be frozen during this time, so the block should either finish
259fast or be very important. 341fast or be very important.
262 344
263sub sync_job(&) { 345sub sync_job(&) {
264 my ($job) = @_; 346 my ($job) = @_;
265 347
266 if ($Coro::current == $Coro::main) { 348 if ($Coro::current == $Coro::main) {
349 my $time = Event::time;
350
267 # this is the main coro, too bad, we have to block 351 # this is the main coro, too bad, we have to block
268 # till the operation succeeds, freezing the server :/ 352 # till the operation succeeds, freezing the server :/
269 353
270 # TODO: use suspend/resume instead 354 # TODO: use suspend/resume instead
271 # (but this is cancel-safe) 355 # (but this is cancel-safe)
272 local $FREEZE = 1; 356 my $freeze_guard = freeze_mainloop;
273 357
274 my $busy = 1; 358 my $busy = 1;
275 my @res; 359 my @res;
276 360
277 (Coro::async { 361 (async {
278 @res = eval { $job->() }; 362 @res = eval { $job->() };
279 warn $@ if $@; 363 warn $@ if $@;
280 undef $busy; 364 undef $busy;
281 })->prio (Coro::PRIO_MAX); 365 })->prio (Coro::PRIO_MAX);
282 366
283 while ($busy) { 367 while ($busy) {
284 Coro::cede_notself; 368 Coro::cede or Event::one_event;
285 Event::one_event unless Coro::nready;
286 } 369 }
370
371 $time = Event::time - $time;
372
373 LOG llevError | logBacktrace, Carp::longmess "long sync job"
374 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
375
376 $tick_start += $time; # do not account sync jobs to server load
287 377
288 wantarray ? @res : $res[0] 378 wantarray ? @res : $res[0]
289 } else { 379 } else {
290 # we are in another coroutine, how wonderful, everything just works 380 # we are in another coroutine, how wonderful, everything just works
291 381
292 $job->() 382 $job->()
293 } 383 }
294} 384}
295 385
296=item $coro = cf::coro { BLOCK } 386=item $coro = cf::async_ext { BLOCK }
297 387
298Creates and returns a new coro. This coro is automcatially being canceled 388Like async, but this coro is automatically being canceled when the
299when the extension calling this is being unloaded. 389extension calling this is being unloaded.
300 390
301=cut 391=cut
302 392
303sub coro(&) { 393sub async_ext(&) {
304 my $cb = shift; 394 my $cb = shift;
305 395
306 my $coro; $coro = async { 396 my $coro = &Coro::async ($cb);
307 eval {
308 $cb->();
309 };
310 warn $@ if $@;
311 };
312 397
313 $coro->on_destroy (sub { 398 $coro->on_destroy (sub {
314 delete $EXT_CORO{$coro+0}; 399 delete $EXT_CORO{$coro+0};
315 }); 400 });
316 $EXT_CORO{$coro+0} = $coro; 401 $EXT_CORO{$coro+0} = $coro;
317 402
318 $coro 403 $coro
319} 404}
320 405
321sub write_runtime { 406=item fork_call { }, $args
322 my $runtime = cf::localdir . "/runtime";
323 407
324 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 408Executes the given code block with the given arguments in a seperate
325 or return; 409process, returning the results. Everything must be serialisable with
410Coro::Storable. May, of course, block. Note that the executed sub may
411never block itself or use any form of Event handling.
326 412
327 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 413=cut
328 (aio_write $fh, 0, (length $value), $value, 0) <= 0
329 and return;
330 414
331 aio_fsync $fh 415sub fork_call(&@) {
332 and return; 416 my ($cb, @args) = @_;
333 417
418# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
419# or die "socketpair: $!";
420 pipe my $fh1, my $fh2
421 or die "pipe: $!";
422
423 if (my $pid = fork) {
334 close $fh 424 close $fh2;
335 or return;
336 425
337 aio_rename "$runtime~", $runtime 426 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
338 and return; 427 $res = Coro::Storable::thaw $res;
339 428
429 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
430
431 die $$res unless "ARRAY" eq ref $res;
432
433 return wantarray ? @$res : $res->[-1];
434 } else {
435 reset_signals;
436 local $SIG{__WARN__};
437 local $SIG{__DIE__};
438 eval {
439 close $fh1;
440
441 my @res = eval { $cb->(@args) };
442 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
443 };
444
445 warn $@ if $@;
446 _exit 0;
340 1 447 }
448}
449
450=item $value = cf::db_get $family => $key
451
452Returns a single value from the environment database.
453
454=item cf::db_put $family => $key => $value
455
456Stores the given C<$value> in the family. It can currently store binary
457data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
458
459=cut
460
461our $DB;
462
463sub db_init {
464 unless ($DB) {
465 $DB = BDB::db_create $DB_ENV;
466
467 cf::sync_job {
468 eval {
469 $DB->set_flags (BDB::CHKSUM);
470
471 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
472 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
473 cf::cleanup "db_open(db): $!" if $!;
474 };
475 cf::cleanup "db_open(db): $@" if $@;
476 };
477 }
478}
479
480sub db_get($$) {
481 my $key = "$_[0]/$_[1]";
482
483 cf::sync_job {
484 BDB::db_get $DB, undef, $key, my $data;
485
486 $! ? ()
487 : $data
488 }
489}
490
491sub db_put($$$) {
492 BDB::dbreq_pri 4;
493 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
494}
495
496=item cf::cache $id => [$paths...], $processversion => $process
497
498Generic caching function that returns the value of the resource $id,
499caching and regenerating as required.
500
501This function can block.
502
503=cut
504
505sub cache {
506 my ($id, $src, $processversion, $process) = @_;
507
508 my $meta =
509 join "\x00",
510 $processversion,
511 map {
512 aio_stat $_
513 and Carp::croak "$_: $!";
514
515 ($_, (stat _)[7,9])
516 } @$src;
517
518 my $dbmeta = db_get cache => "$id/meta";
519 if ($dbmeta ne $meta) {
520 # changed, we may need to process
521
522 my @data;
523 my $md5;
524
525 for (0 .. $#$src) {
526 0 <= aio_load $src->[$_], $data[$_]
527 or Carp::croak "$src->[$_]: $!";
528 }
529
530 # if processing is expensive, check
531 # checksum first
532 if (1) {
533 $md5 =
534 join "\x00",
535 $processversion,
536 map {
537 Coro::cede;
538 ($src->[$_], Digest::MD5::md5_hex $data[$_])
539 } 0.. $#$src;
540
541
542 my $dbmd5 = db_get cache => "$id/md5";
543 if ($dbmd5 eq $md5) {
544 db_put cache => "$id/meta", $meta;
545
546 return db_get cache => "$id/data";
547 }
548 }
549
550 my $t1 = Time::HiRes::time;
551 my $data = $process->(\@data);
552 my $t2 = Time::HiRes::time;
553
554 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
555
556 db_put cache => "$id/data", $data;
557 db_put cache => "$id/md5" , $md5;
558 db_put cache => "$id/meta", $meta;
559
560 return $data;
561 }
562
563 db_get cache => "$id/data"
564}
565
566=item cf::datalog type => key => value, ...
567
568Log a datalog packet of the given type with the given key-value pairs.
569
570=cut
571
572sub datalog($@) {
573 my ($type, %kv) = @_;
574 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
341} 575}
342 576
343=back 577=back
344 578
345=cut 579=cut
346
347#############################################################################
348
349package cf::path;
350
351sub new {
352 my ($class, $path, $base) = @_;
353
354 $path = $path->as_string if ref $path;
355
356 my $self = bless { }, $class;
357
358 # {... are special paths that are not touched
359 # ?xxx/... are special absolute paths
360 # ?random/... random maps
361 # /! non-realised random map exit
362 # /... normal maps
363 # ~/... per-player maps without a specific player (DO NOT USE)
364 # ~user/... per-player map of a specific user
365
366 if ($path =~ /^{/) {
367 # fine as it is
368 } elsif ($path =~ s{^\?random/}{}) {
369 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
370 $self->{random} = cf::from_json $data;
371 } else {
372 if ($path =~ s{^~([^/]+)?}{}) {
373 $self->{user_rel} = 1;
374
375 if (defined $1) {
376 $self->{user} = $1;
377 } elsif ($base =~ m{^~([^/]+)/}) {
378 $self->{user} = $1;
379 } else {
380 warn "cannot resolve user-relative path without user <$path,$base>\n";
381 }
382 } elsif ($path =~ /^\//) {
383 # already absolute
384 } else {
385 $base =~ s{[^/]+/?$}{};
386 return $class->new ("$base/$path");
387 }
388
389 for ($path) {
390 redo if s{/\.?/}{/};
391 redo if s{/[^/]+/\.\./}{/};
392 }
393 }
394
395 $self->{path} = $path;
396
397 $self
398}
399
400# the name / primary key / in-game path
401sub as_string {
402 my ($self) = @_;
403
404 $self->{user_rel} ? "~$self->{user}$self->{path}"
405 : $self->{random} ? "?random/$self->{path}"
406 : $self->{path}
407}
408
409# the displayed name, this is a one way mapping
410sub visible_name {
411 my ($self) = @_;
412
413# if (my $rmp = $self->{random}) {
414# # todo: be more intelligent about this
415# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
416# } else {
417 $self->as_string
418# }
419}
420
421# escape the /'s in the path
422sub _escaped_path {
423 # ∕ is U+2215
424 (my $path = $_[0]{path}) =~ s/\//∕/g;
425 $path
426}
427
428# the original (read-only) location
429sub load_path {
430 my ($self) = @_;
431
432 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
433}
434
435# the temporary/swap location
436sub save_path {
437 my ($self) = @_;
438
439 $self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
440 : $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
441 : sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
442}
443
444# the unique path, might be eq to save_path
445sub uniq_path {
446 my ($self) = @_;
447
448 $self->{user_rel} || $self->{random}
449 ? undef
450 : sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
451}
452
453# return random map parameters, or undef
454sub random_map_params {
455 my ($self) = @_;
456
457 $self->{random}
458}
459
460# this is somewhat ugly, but style maps do need special treatment
461sub is_style_map {
462 $_[0]{path} =~ m{^/styles/}
463}
464
465package cf;
466 580
467############################################################################# 581#############################################################################
468 582
469=head2 ATTACHABLE OBJECTS 583=head2 ATTACHABLE OBJECTS
470 584
472attach callbacks/event handlers (a collection of which is called an "attachment") 586attach callbacks/event handlers (a collection of which is called an "attachment")
473to it. All such attachable objects support the following methods. 587to it. All such attachable objects support the following methods.
474 588
475In the following description, CLASS can be any of C<global>, C<object> 589In the following description, CLASS can be any of C<global>, C<object>
476C<player>, C<client> or C<map> (i.e. the attachable objects in 590C<player>, C<client> or C<map> (i.e. the attachable objects in
477crossfire+). 591Crossfire TRT).
478 592
479=over 4 593=over 4
480 594
481=item $attachable->attach ($attachment, key => $value...) 595=item $attachable->attach ($attachment, key => $value...)
482 596
596our @CB_TYPE = (); # registry for type (cf-object class) based events 710our @CB_TYPE = (); # registry for type (cf-object class) based events
597our @CB_MAP = (); 711our @CB_MAP = ();
598 712
599my %attachment; 713my %attachment;
600 714
715sub cf::attachable::thawer_merge {
716 # simply override everything except _meta
717 local $_[0]{_meta};
718 %{$_[0]} = %{$_[1]};
719}
720
601sub _attach_cb($$$$) { 721sub _attach_cb($$$$) {
602 my ($registry, $event, $prio, $cb) = @_; 722 my ($registry, $event, $prio, $cb) = @_;
603 723
604 use sort 'stable'; 724 use sort 'stable';
605 725
639 $registry = $CB_TYPE[$object_type] ||= []; 759 $registry = $CB_TYPE[$object_type] ||= [];
640 760
641 } elsif ($type eq "subtype") { 761 } elsif ($type eq "subtype") {
642 defined $object_type or Carp::croak "subtype specified without type"; 762 defined $object_type or Carp::croak "subtype specified without type";
643 my $object_subtype = shift @arg; 763 my $object_subtype = shift @arg;
644 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 764 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
645 765
646 } elsif ($type eq "package") { 766 } elsif ($type eq "package") {
647 my $pkg = shift @arg; 767 my $pkg = shift @arg;
648 768
649 while (my ($name, $id) = each %cb_id) { 769 while (my ($name, $id) = each %cb_id) {
678 _attach $registry, $klass, @attach; 798 _attach $registry, $klass, @attach;
679 } 799 }
680 800
681 $obj->{$name} = \%arg; 801 $obj->{$name} = \%arg;
682 } else { 802 } else {
683 warn "object uses attachment '$name' that is not available, postponing.\n"; 803 warn "object uses attachment '$name' which is not available, postponing.\n";
684 } 804 }
685 805
686 $obj->{_attachment}{$name} = undef; 806 $obj->{_attachment}{$name} = undef;
687} 807}
688 808
690 if (ref $_[0]) { 810 if (ref $_[0]) {
691 _object_attach @_; 811 _object_attach @_;
692 } else { 812 } else {
693 _attach shift->_attach_registry, @_; 813 _attach shift->_attach_registry, @_;
694 } 814 }
815 _recalc_want;
695}; 816};
696 817
697# all those should be optimised 818# all those should be optimised
698sub cf::attachable::detach { 819sub cf::attachable::detach {
699 my ($obj, $name) = @_; 820 my ($obj, $name) = @_;
702 delete $obj->{_attachment}{$name}; 823 delete $obj->{_attachment}{$name};
703 reattach ($obj); 824 reattach ($obj);
704 } else { 825 } else {
705 Carp::croak "cannot, currently, detach class attachments"; 826 Carp::croak "cannot, currently, detach class attachments";
706 } 827 }
828 _recalc_want;
707}; 829};
708 830
709sub cf::attachable::attached { 831sub cf::attachable::attached {
710 my ($obj, $name) = @_; 832 my ($obj, $name) = @_;
711 833
776# object support 898# object support
777 899
778sub reattach { 900sub reattach {
779 # basically do the same as instantiate, without calling instantiate 901 # basically do the same as instantiate, without calling instantiate
780 my ($obj) = @_; 902 my ($obj) = @_;
903
904 bless $obj, ref $obj; # re-bless in case extensions have been reloaded
781 905
782 my $registry = $obj->registry; 906 my $registry = $obj->registry;
783 907
784 @$registry = (); 908 @$registry = ();
785 909
832 $filename, length $$rdata, scalar @$objs; 956 $filename, length $$rdata, scalar @$objs;
833 957
834 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 958 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
835 chmod SAVE_MODE, $fh; 959 chmod SAVE_MODE, $fh;
836 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 960 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
837 aio_fsync $fh; 961 aio_fsync $fh if $cf::USE_FSYNC;
838 close $fh; 962 close $fh;
839 963
840 if (@$objs) { 964 if (@$objs) {
841 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 965 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
842 chmod SAVE_MODE, $fh; 966 chmod SAVE_MODE, $fh;
843 my $data = Storable::nfreeze { version => 1, objs => $objs }; 967 my $data = Storable::nfreeze { version => 1, objs => $objs };
844 aio_write $fh, 0, (length $data), $data, 0; 968 aio_write $fh, 0, (length $data), $data, 0;
845 aio_fsync $fh; 969 aio_fsync $fh if $cf::USE_FSYNC;
846 close $fh; 970 close $fh;
847 aio_rename "$filename.pst~", "$filename.pst"; 971 aio_rename "$filename.pst~", "$filename.pst";
848 } 972 }
849 } else { 973 } else {
850 aio_unlink "$filename.pst"; 974 aio_unlink "$filename.pst";
882 or return; 1006 or return;
883 $av = eval { (Storable::thaw $av)->{objs} }; 1007 $av = eval { (Storable::thaw $av)->{objs} };
884 } 1008 }
885 1009
886 warn sprintf "loading %s (%d)\n", 1010 warn sprintf "loading %s (%d)\n",
887 $filename, length $data, scalar @{$av || []};#d# 1011 $filename, length $data, scalar @{$av || []};
888 return ($data, $av); 1012 return ($data, $av);
889} 1013}
1014
1015=head2 COMMAND CALLBACKS
1016
1017=over 4
1018
1019=cut
890 1020
891############################################################################# 1021#############################################################################
892# command handling &c 1022# command handling &c
893 1023
894=item cf::register_command $name => \&callback($ob,$args); 1024=item cf::register_command $name => \&callback($ob,$args);
907 push @{ $COMMAND{$name} }, [$caller, $cb]; 1037 push @{ $COMMAND{$name} }, [$caller, $cb];
908} 1038}
909 1039
910=item cf::register_extcmd $name => \&callback($pl,$packet); 1040=item cf::register_extcmd $name => \&callback($pl,$packet);
911 1041
912Register a callbackf ro execution when the client sends an extcmd packet. 1042Register a callback for execution when the client sends an (synchronous)
1043extcmd packet. Ext commands will be processed in the order they are
1044received by the server, like other user commands. The first argument is
1045the logged-in player. Ext commands can only be processed after a player
1046has logged in successfully.
913 1047
914If the callback returns something, it is sent back as if reply was being 1048If the callback returns something, it is sent back as if reply was being
915called. 1049called.
916 1050
1051=item cf::register_exticmd $name => \&callback($ns,$packet);
1052
1053Register a callback for execution when the client sends an (asynchronous)
1054exticmd packet. Exti commands are processed by the server as soon as they
1055are received, i.e. out of order w.r.t. other commands. The first argument
1056is a client socket. Exti commands can be received anytime, even before
1057log-in.
1058
1059If the callback returns something, it is sent back as if reply was being
1060called.
1061
917=cut 1062=cut
918 1063
919sub register_extcmd { 1064sub register_extcmd {
920 my ($name, $cb) = @_; 1065 my ($name, $cb) = @_;
921 1066
922 my $caller = caller;
923 #warn "registering extcmd '$name' to '$caller'";
924
925 $EXTCMD{$name} = [$cb, $caller]; 1067 $EXTCMD{$name} = $cb;
1068}
1069
1070sub register_exticmd {
1071 my ($name, $cb) = @_;
1072
1073 $EXTICMD{$name} = $cb;
926} 1074}
927 1075
928cf::player->attach ( 1076cf::player->attach (
929 on_command => sub { 1077 on_command => sub {
930 my ($pl, $name, $params) = @_; 1078 my ($pl, $name, $params) = @_;
943 1091
944 my $msg = eval { from_json $buf }; 1092 my $msg = eval { from_json $buf };
945 1093
946 if (ref $msg) { 1094 if (ref $msg) {
947 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1095 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
948 if (my %reply = $cb->[0]->($pl, $msg)) { 1096 if (my %reply = $cb->($pl, $msg)) {
949 $pl->ext_reply ($msg->{msgid}, %reply); 1097 $pl->ext_reply ($msg->{msgid}, %reply);
950 } 1098 }
951 } 1099 }
952 } else { 1100 } else {
953 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1101 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
955 1103
956 cf::override; 1104 cf::override;
957 }, 1105 },
958); 1106);
959 1107
960sub register {
961 my ($base, $pkg) = @_;
962
963 #TODO
964}
965
966sub load_extension { 1108sub load_extensions {
1109 cf::sync_job {
1110 my %todo;
1111
1112 for my $path (<$LIBDIR/*.ext>) {
1113 next unless -r $path;
1114
1115 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1116 my $base = $1;
1117 my $pkg = $1;
1118 $pkg =~ s/[^[:word:]]/_/g;
1119 $pkg = "ext::$pkg";
1120
1121 open my $fh, "<:utf8", $path
1122 or die "$path: $!";
1123
1124 my $source = do { local $/; <$fh> };
1125
1126 my %ext = (
1127 path => $path,
1128 base => $base,
1129 pkg => $pkg,
1130 );
1131
1132 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1133 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1134
1135 $ext{source} =
1136 "package $pkg; use strict; use utf8;\n"
1137 . "#line 1 \"$path\"\n{\n"
1138 . $source
1139 . "\n};\n1";
1140
1141 $todo{$base} = \%ext;
1142 }
1143
1144 my %done;
1145 while (%todo) {
1146 my $progress;
1147
1148 while (my ($k, $v) = each %todo) {
1149 for (split /,\s*/, $v->{meta}{depends}) {
1150 goto skip
1151 unless exists $done{$_};
1152 }
1153
1154 warn "... loading '$k' into '$v->{pkg}'\n";
1155
1156 unless (eval $v->{source}) {
1157 my $msg = $@ ? "$v->{path}: $@\n"
1158 : "$v->{base}: extension inactive.\n";
1159
1160 if (exists $v->{meta}{mandatory}) {
1161 warn $msg;
1162 warn "mandatory extension failed to load, exiting.\n";
1163 exit 1;
1164 }
1165
1166 warn $msg;
1167 }
1168
1169 $done{$k} = delete $todo{$k};
1170 push @EXTS, $v->{pkg};
1171 $progress = 1;
1172 }
1173
1174 skip:
1175 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1176 unless $progress;
1177 }
1178 };
1179}
1180
1181#############################################################################
1182
1183=back
1184
1185=head2 CORE EXTENSIONS
1186
1187Functions and methods that extend core crossfire objects.
1188
1189=cut
1190
1191package cf::player;
1192
1193use Coro::AIO;
1194
1195=head3 cf::player
1196
1197=over 4
1198
1199=item cf::player::find $login
1200
1201Returns the given player object, loading it if necessary (might block).
1202
1203=cut
1204
1205sub playerdir($) {
1206 "$PLAYERDIR/"
1207 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1208}
1209
1210sub path($) {
1211 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1212
1213 (playerdir $login) . "/playerdata"
1214}
1215
1216sub find_active($) {
1217 $cf::PLAYER{$_[0]}
1218 and $cf::PLAYER{$_[0]}->active
1219 and $cf::PLAYER{$_[0]}
1220}
1221
1222sub exists($) {
1223 my ($login) = @_;
1224
1225 $cf::PLAYER{$login}
1226 or cf::sync_job { !aio_stat path $login }
1227}
1228
1229sub find($) {
1230 return $cf::PLAYER{$_[0]} || do {
1231 my $login = $_[0];
1232
1233 my $guard = cf::lock_acquire "user_find:$login";
1234
1235 $cf::PLAYER{$_[0]} || do {
1236 # rename old playerfiles to new ones
1237 #TODO: remove when no longer required
1238 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1239 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1240 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1241 aio_unlink +(playerdir $login) . "/$login.pl";
1242
1243 my $pl = load_pl path $login
1244 or return;
1245 $cf::PLAYER{$login} = $pl
1246 }
1247 }
1248}
1249
1250sub save($) {
1251 my ($pl) = @_;
1252
1253 return if $pl->{deny_save};
1254
1255 my $path = path $pl;
1256 my $guard = cf::lock_acquire "user_save:$path";
1257
1258 return if $pl->{deny_save};
1259
1260 aio_mkdir playerdir $pl, 0770;
1261 $pl->{last_save} = $cf::RUNTIME;
1262
1263 $pl->save_pl ($path);
1264 Coro::cede;
1265}
1266
1267sub new($) {
1268 my ($login) = @_;
1269
1270 my $self = create;
1271
1272 $self->ob->name ($login);
1273 $self->{deny_save} = 1;
1274
1275 $cf::PLAYER{$login} = $self;
1276
1277 $self
1278}
1279
1280=item $pl->quit_character
1281
1282Nukes the player without looking back. If logged in, the connection will
1283be destroyed. May block for a long time.
1284
1285=cut
1286
1287sub quit_character {
1288 my ($pl) = @_;
1289
1290 my $name = $pl->ob->name;
1291
1292 $pl->{deny_save} = 1;
1293 $pl->password ("*"); # this should lock out the player until we nuked the dir
1294
1295 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1296 $pl->deactivate;
1297 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1298 $pl->ns->destroy if $pl->ns;
1299
1300 my $path = playerdir $pl;
1301 my $temp = "$path~$cf::RUNTIME~deleting~";
1302 aio_rename $path, $temp;
1303 delete $cf::PLAYER{$pl->ob->name};
1304 $pl->destroy;
1305
1306 my $prefix = qr<^~\Q$name\E/>;
1307
1308 # nuke player maps
1309 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1310
1311 IO::AIO::aio_rmtree $temp;
1312}
1313
1314=item $pl->kick
1315
1316Kicks a player out of the game. This destroys the connection.
1317
1318=cut
1319
1320sub kick {
1321 my ($pl, $kicker) = @_;
1322
1323 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1324 $pl->killer ("kicked");
1325 $pl->ns->destroy;
1326}
1327
1328=item cf::player::list_logins
1329
1330Returns am arrayref of all valid playernames in the system, can take a
1331while and may block, so not sync_job-capable, ever.
1332
1333=cut
1334
1335sub list_logins {
1336 my $dirs = aio_readdir $PLAYERDIR
1337 or return [];
1338
1339 my @logins;
1340
1341 for my $login (@$dirs) {
1342 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1343 aio_read $fh, 0, 512, my $buf, 0 or next;
1344 $buf !~ /^password -------------$/m or next; # official not-valid tag
1345
1346 utf8::decode $login;
1347 push @logins, $login;
1348 }
1349
1350 \@logins
1351}
1352
1353=item $player->maps
1354
1355Returns an arrayref of map paths that are private for this
1356player. May block.
1357
1358=cut
1359
1360sub maps($) {
1361 my ($pl) = @_;
1362
1363 $pl = ref $pl ? $pl->ob->name : $pl;
1364
1365 my $files = aio_readdir playerdir $pl
1366 or return;
1367
1368 my @paths;
1369
1370 for (@$files) {
1371 utf8::decode $_;
1372 next if /\.(?:pl|pst)$/;
1373 next unless /^$PATH_SEP/o;
1374
1375 push @paths, cf::map::normalise "~$pl/$_";
1376 }
1377
1378 \@paths
1379}
1380
1381=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1382
1383Expand crossfire pod fragments into protocol xml.
1384
1385=cut
1386
1387sub expand_cfpod {
1388 ((my $self), (local $_)) = @_;
1389
1390 # escape & and <
1391 s/&/&amp;/g;
1392 s/(?<![BIUGH])</&lt;/g;
1393
1394 # this is buggy, it needs to properly take care of nested <'s
1395
1396 1 while
1397 # replace B<>, I<>, U<> etc.
1398 s/B<([^\>]*)>/<b>$1<\/b>/
1399 || s/I<([^\>]*)>/<i>$1<\/i>/
1400 || s/U<([^\>]*)>/<u>$1<\/u>/
1401 # replace G<male|female> tags
1402 || s{G<([^>|]*)\|([^>]*)>}{
1403 $self->gender ? $2 : $1
1404 }ge
1405 # replace H<hint text>
1406 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
1407
1408 # create single paragraphs (very hackish)
1409 s/(?<=\S)\n(?=\w)/ /g;
1410
1411 $_
1412}
1413
1414=item $player->ext_reply ($msgid, %msg)
1415
1416Sends an ext reply to the player.
1417
1418=cut
1419
1420sub ext_reply($$%) {
1421 my ($self, $id, %msg) = @_;
1422
1423 $msg{msgid} = $id;
1424 $self->send ("ext " . cf::to_json \%msg);
1425}
1426
1427=item $player->ext_event ($type, %msg)
1428
1429Sends an ext event to the client.
1430
1431=cut
1432
1433sub ext_event($$%) {
1434 my ($self, $type, %msg) = @_;
1435
1436 $self->ns->ext_event ($type, %msg);
1437}
1438
1439=head3 cf::region
1440
1441=over 4
1442
1443=cut
1444
1445package cf::region;
1446
1447=item cf::region::find_by_path $path
1448
1449Tries to decuce the likely region for a map knowing only its path.
1450
1451=cut
1452
1453sub find_by_path($) {
967 my ($path) = @_; 1454 my ($path) = @_;
968 1455
969 $path =~ /([^\/\\]+)\.ext$/ or die "$path"; 1456 my ($match, $specificity);
970 my $base = $1;
971 my $pkg = $1;
972 $pkg =~ s/[^[:word:]]/_/g;
973 $pkg = "ext::$pkg";
974 1457
975 warn "loading '$path' into '$pkg'\n"; 1458 for my $region (list) {
976 1459 if ($region->match && $path =~ $region->match) {
977 open my $fh, "<:utf8", $path 1460 ($match, $specificity) = ($region, $region->specificity)
978 or die "$path: $!"; 1461 if $region->specificity > $specificity;
979 1462 }
980 my $source =
981 "package $pkg; use strict; use utf8;\n"
982 . "#line 1 \"$path\"\n{\n"
983 . (do { local $/; <$fh> })
984 . "\n};\n1";
985
986 eval $source
987 or die $@ ? "$path: $@\n"
988 : "extension disabled.\n";
989
990 push @exts, $pkg;
991 $ext_pkg{$base} = $pkg;
992
993# no strict 'refs';
994# @{"$pkg\::ISA"} = ext::;
995
996 register $base, $pkg;
997}
998
999sub unload_extension {
1000 my ($pkg) = @_;
1001
1002 warn "removing extension $pkg\n";
1003
1004 # remove hooks
1005 #TODO
1006# for my $idx (0 .. $#PLUGIN_EVENT) {
1007# delete $hook[$idx]{$pkg};
1008# } 1463 }
1009 1464
1010 # remove commands 1465 $match
1011 for my $name (keys %COMMAND) {
1012 my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1013
1014 if (@cb) {
1015 $COMMAND{$name} = \@cb;
1016 } else {
1017 delete $COMMAND{$name};
1018 }
1019 }
1020
1021 # remove extcmds
1022 for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1023 delete $EXTCMD{$name};
1024 }
1025
1026 if (my $cb = $pkg->can ("unload")) {
1027 eval {
1028 $cb->($pkg);
1029 1
1030 } or warn "$pkg unloaded, but with errors: $@";
1031 }
1032
1033 Symbol::delete_package $pkg;
1034}
1035
1036sub load_extensions {
1037 for my $ext (<$LIBDIR/*.ext>) {
1038 next unless -r $ext;
1039 eval {
1040 load_extension $ext;
1041 1
1042 } or warn "$ext not loaded: $@";
1043 }
1044}
1045
1046#############################################################################
1047# load/save/clean perl data associated with a map
1048
1049*cf::mapsupport::on_clean = sub {
1050 my ($map) = @_;
1051
1052 my $path = $map->tmpname;
1053 defined $path or return;
1054
1055 unlink "$path.pst";
1056};
1057
1058cf::map->attach (prio => -10000, package => cf::mapsupport::);
1059
1060#############################################################################
1061# load/save perl data associated with player->ob objects
1062
1063sub all_objects(@) {
1064 @_, map all_objects ($_->inv), @_
1065}
1066
1067# TODO: compatibility cruft, remove when no longer needed
1068cf::player->attach (
1069 on_load => sub {
1070 my ($pl, $path) = @_;
1071
1072 for my $o (all_objects $pl->ob) {
1073 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1074 $o->set_ob_key_value ("_perl_data");
1075
1076 %$o = %{ Storable::thaw pack "H*", $value };
1077 }
1078 }
1079 },
1080);
1081
1082#############################################################################
1083
1084=head2 CORE EXTENSIONS
1085
1086Functions and methods that extend core crossfire objects.
1087
1088=head3 cf::player
1089
1090=over 4
1091
1092=item cf::player::exists $login
1093
1094Returns true when the given account exists.
1095
1096=cut
1097
1098sub cf::player::exists($) {
1099 cf::player::find $_[0]
1100 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;
1101}
1102
1103=item $player->ext_reply ($msgid, $msgtype, %msg)
1104
1105Sends an ext reply to the player.
1106
1107=cut
1108
1109sub cf::player::ext_reply($$$%) {
1110 my ($self, $id, %msg) = @_;
1111
1112 $msg{msgid} = $id;
1113
1114 $self->send ("ext " . to_json \%msg);
1115} 1466}
1116 1467
1117=back 1468=back
1118
1119 1469
1120=head3 cf::map 1470=head3 cf::map
1121 1471
1122=over 4 1472=over 4
1123 1473
1126package cf::map; 1476package cf::map;
1127 1477
1128use Fcntl; 1478use Fcntl;
1129use Coro::AIO; 1479use Coro::AIO;
1130 1480
1481use overload
1482 '""' => \&as_string,
1483 fallback => 1;
1484
1131our $MAX_RESET = 7200; 1485our $MAX_RESET = 3600;
1132our $DEFAULT_RESET = 3600; 1486our $DEFAULT_RESET = 3000;
1133 1487
1134sub generate_random_map { 1488sub generate_random_map {
1135 my ($path, $rmp) = @_; 1489 my ($self, $rmp) = @_;
1136
1137 # mit "rum" bekleckern, nicht 1490 # mit "rum" bekleckern, nicht
1138 cf::map::_create_random_map 1491 $self->_create_random_map (
1139 $path,
1140 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1492 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1141 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1493 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1142 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1494 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1143 $rmp->{exit_on_final_map}, 1495 $rmp->{exit_on_final_map},
1144 $rmp->{xsize}, $rmp->{ysize}, 1496 $rmp->{xsize}, $rmp->{ysize},
1145 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3}, 1497 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1146 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase}, 1498 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1147 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation}, 1499 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1148 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp}, 1500 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1149 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1501 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1150 (cf::region::find $rmp->{region}) 1502 (cf::region::find $rmp->{region}), $rmp->{custom}
1503 )
1504}
1505
1506=item cf::map->register ($regex, $prio)
1507
1508Register a handler for the map path matching the given regex at the
1509givne priority (higher is better, built-in handlers have priority 0, the
1510default).
1511
1512=cut
1513
1514sub register {
1515 my (undef, $regex, $prio) = @_;
1516 my $pkg = caller;
1517
1518 no strict;
1519 push @{"$pkg\::ISA"}, __PACKAGE__;
1520
1521 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1522}
1523
1524# also paths starting with '/'
1525$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1526
1527sub thawer_merge {
1528 my ($self, $merge) = @_;
1529
1530 # we have to keep some variables in memory intact
1531 local $self->{path};
1532 local $self->{load_path};
1533
1534 $self->SUPER::thawer_merge ($merge);
1535}
1536
1537sub normalise {
1538 my ($path, $base) = @_;
1539
1540 $path = "$path"; # make sure its a string
1541
1542 $path =~ s/\.map$//;
1543
1544 # map plan:
1545 #
1546 # /! non-realised random map exit (special hack!)
1547 # {... are special paths that are not being touched
1548 # ?xxx/... are special absolute paths
1549 # ?random/... random maps
1550 # /... normal maps
1551 # ~user/... per-player map of a specific user
1552
1553 $path =~ s/$PATH_SEP/\//go;
1554
1555 # treat it as relative path if it starts with
1556 # something that looks reasonable
1557 if ($path =~ m{^(?:\./|\.\./|\w)}) {
1558 $base or Carp::carp "normalise called with relative path and no base: '$path'";
1559
1560 $base =~ s{[^/]+/?$}{};
1561 $path = "$base/$path";
1562 }
1563
1564 for ($path) {
1565 redo if s{//}{/};
1566 redo if s{/\.?/}{/};
1567 redo if s{/[^/]+/\.\./}{/};
1568 }
1569
1570 $path
1571}
1572
1573sub new_from_path {
1574 my (undef, $path, $base) = @_;
1575
1576 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1577
1578 $path = normalise $path, $base;
1579
1580 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1581 if ($path =~ $EXT_MAP{$pkg}[1]) {
1582 my $self = bless cf::map::new, $pkg;
1583 $self->{path} = $path; $self->path ($path);
1584 $self->init; # pass $1 etc.
1585 return $self;
1586 }
1587 }
1588
1589 Carp::carp "unable to resolve path '$path' (base '$base').";
1590 ()
1591}
1592
1593sub init {
1594 my ($self) = @_;
1595
1596 $self
1597}
1598
1599sub as_string {
1600 my ($self) = @_;
1601
1602 "$self->{path}"
1603}
1604
1605# the displayed name, this is a one way mapping
1606sub visible_name {
1607 &as_string
1608}
1609
1610# the original (read-only) location
1611sub load_path {
1612 my ($self) = @_;
1613
1614 "$MAPDIR/$self->{path}.map"
1615}
1616
1617# the temporary/swap location
1618sub save_path {
1619 my ($self) = @_;
1620
1621 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1622 "$TMPDIR/$path.map"
1623}
1624
1625# the unique path, undef == no special unique path
1626sub uniq_path {
1627 my ($self) = @_;
1628
1629 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1630 "$UNIQUEDIR/$path"
1151} 1631}
1152 1632
1153# and all this just because we cannot iterate over 1633# and all this just because we cannot iterate over
1154# all maps in C++... 1634# all maps in C++...
1155sub change_all_map_light { 1635sub change_all_map_light {
1157 1637
1158 $_->change_map_light ($change) 1638 $_->change_map_light ($change)
1159 for grep $_->outdoor, values %cf::MAP; 1639 for grep $_->outdoor, values %cf::MAP;
1160} 1640}
1161 1641
1642sub decay_objects {
1643 my ($self) = @_;
1644
1645 return if $self->{deny_reset};
1646
1647 $self->do_decay_objects;
1648}
1649
1650sub unlink_save {
1651 my ($self) = @_;
1652
1653 utf8::encode (my $save = $self->save_path);
1654 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1655 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1656}
1657
1162sub try_load_header($) { 1658sub load_header_from($) {
1163 my ($path) = @_; 1659 my ($self, $path) = @_;
1164 1660
1165 utf8::encode $path; 1661 utf8::encode $path;
1166 aio_open $path, O_RDONLY, 0 1662 #aio_open $path, O_RDONLY, 0
1663 # or return;
1664
1665 $self->_load_header ($path)
1167 or return; 1666 or return;
1168 1667
1169 my $map = cf::map::new 1668 $self->{load_path} = $path;
1669
1670 1
1671}
1672
1673sub load_header_orig {
1674 my ($self) = @_;
1675
1676 $self->load_header_from ($self->load_path)
1677}
1678
1679sub load_header_temp {
1680 my ($self) = @_;
1681
1682 $self->load_header_from ($self->save_path)
1683}
1684
1685sub prepare_temp {
1686 my ($self) = @_;
1687
1688 $self->last_access ((delete $self->{last_access})
1689 || $cf::RUNTIME); #d#
1690 # safety
1691 $self->{instantiate_time} = $cf::RUNTIME
1692 if $self->{instantiate_time} > $cf::RUNTIME;
1693}
1694
1695sub prepare_orig {
1696 my ($self) = @_;
1697
1698 $self->{load_original} = 1;
1699 $self->{instantiate_time} = $cf::RUNTIME;
1700 $self->last_access ($cf::RUNTIME);
1701 $self->instantiate;
1702}
1703
1704sub load_header {
1705 my ($self) = @_;
1706
1707 if ($self->load_header_temp) {
1708 $self->prepare_temp;
1709 } else {
1710 $self->load_header_orig
1170 or return; 1711 or return;
1712 $self->prepare_orig;
1713 }
1171 1714
1172 $map->load_header ($path) 1715 $self->{deny_reset} = 1
1173 or return; 1716 if $self->no_reset;
1174 1717
1175 $map->{load_path} = $path; 1718 $self->default_region (cf::region::find_by_path $self->{path})
1719 unless $self->default_region;
1176 1720
1177 $map 1721 1
1178} 1722}
1179 1723
1724sub find;
1180sub find_map { 1725sub find {
1181 my ($path, $origin) = @_; 1726 my ($path, $origin) = @_;
1182 1727
1183 #warn "find_map<$path,$origin>\n";#d#
1184
1185 $path = new cf::path $path, $origin && $origin->path; 1728 $path = normalise $path, $origin && $origin->path;
1186 my $key = $path->as_string;
1187 1729
1188 cf::lock_wait "map_find:$key"; 1730 cf::lock_wait "map_find:$path";
1189 1731
1190 $cf::MAP{$key} || do { 1732 $cf::MAP{$path} || do {
1191 my $guard = cf::lock_acquire "map_find:$key"; 1733 my $guard = cf::lock_acquire "map_find:$path";
1192 1734 my $map = new_from_path cf::map $path
1193 # do it the slow way
1194 my $map = try_load_header $path->save_path;
1195
1196 if ($map) {
1197 # safety
1198 $map->{instantiate_time} = $cf::RUNTIME
1199 if $map->{instantiate_time} > $cf::RUNTIME;
1200 } else {
1201 if (my $rmp = $path->random_map_params) {
1202 $map = generate_random_map $key, $rmp;
1203 } else {
1204 $map = try_load_header $path->load_path;
1205 }
1206
1207 $map or return; 1735 or return;
1208 1736
1209 $map->{load_original} = 1;
1210 $map->{instantiate_time} = $cf::RUNTIME;
1211 $map->instantiate;
1212
1213 # per-player maps become, after loading, normal maps
1214 $map->per_player (0) if $path->{user_rel};
1215 }
1216
1217 $map->path ($key);
1218 $map->{path} = $path;
1219 $map->{last_save} = $cf::RUNTIME; 1737 $map->{last_save} = $cf::RUNTIME;
1220 $map->last_access ($cf::RUNTIME);
1221 1738
1222 if ($map->should_reset) { 1739 $map->load_header
1740 or return;
1741
1742 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1743 # doing this can freeze the server in a sync job, obviously
1744 #$cf::WAIT_FOR_TICK->wait;
1223 $map->reset; 1745 $map->reset;
1224 $map = find_map $path; 1746 undef $guard;
1747 return find $path;
1225 } 1748 }
1226 1749
1227 $cf::MAP{$key} = $map 1750 $cf::MAP{$path} = $map
1228 } 1751 }
1229} 1752}
1753
1754sub pre_load { }
1755sub post_load { }
1230 1756
1231sub load { 1757sub load {
1232 my ($self) = @_; 1758 my ($self) = @_;
1233 1759
1760 local $self->{deny_reset} = 1; # loading can take a long time
1761
1234 my $path = $self->{path}; 1762 my $path = $self->{path};
1763
1764 {
1235 my $guard = cf::lock_acquire "map_load:" . $path->as_string; 1765 my $guard = cf::lock_acquire "map_load:$path";
1236 1766
1237 return if $self->in_memory != cf::MAP_SWAPPED; 1767 return if $self->in_memory != cf::MAP_SWAPPED;
1238 1768
1239 $self->in_memory (cf::MAP_LOADING); 1769 $self->in_memory (cf::MAP_LOADING);
1240 1770
1241 $self->alloc; 1771 $self->alloc;
1772
1773 $self->pre_load;
1774 Coro::cede;
1775
1242 $self->load_objects ($self->{load_path}, 1) 1776 $self->_load_objects ($self->{load_path}, 1)
1243 or return; 1777 or return;
1244 1778
1245 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1779 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1246 if delete $self->{load_original}; 1780 if delete $self->{load_original};
1247 1781
1248 if (my $uniq = $path->uniq_path) { 1782 if (my $uniq = $self->uniq_path) {
1249 utf8::encode $uniq; 1783 utf8::encode $uniq;
1250 if (aio_open $uniq, O_RDONLY, 0) { 1784 if (aio_open $uniq, O_RDONLY, 0) {
1251 $self->clear_unique_items; 1785 $self->clear_unique_items;
1252 $self->load_objects ($uniq, 0); 1786 $self->_load_objects ($uniq, 0);
1253 } 1787 }
1254 } 1788 }
1255 1789
1790 Coro::cede;
1256 # now do the right thing for maps 1791 # now do the right thing for maps
1257 $self->link_multipart_objects; 1792 $self->link_multipart_objects;
1258
1259 if ($self->{path}->is_style_map) {
1260 $self->{deny_save} = 1;
1261 $self->{deny_reset} = 1;
1262 } else {
1263 $self->fix_auto_apply;
1264 $self->decay_objects;
1265 $self->update_buttons;
1266 $self->set_darkness_map;
1267 $self->difficulty ($self->estimate_difficulty) 1793 $self->difficulty ($self->estimate_difficulty)
1268 unless $self->difficulty; 1794 unless $self->difficulty;
1795 Coro::cede;
1796
1797 unless ($self->{deny_activate}) {
1798 $self->decay_objects;
1799 $self->fix_auto_apply;
1800 $self->update_buttons;
1801 Coro::cede;
1802 $self->set_darkness_map;
1803 Coro::cede;
1269 $self->activate; 1804 $self->activate;
1270 } 1805 }
1271 1806
1272 $self->in_memory (cf::MAP_IN_MEMORY); 1807 $self->in_memory (cf::MAP_IN_MEMORY);
1273} 1808 }
1274 1809
1275sub load_map_sync { 1810 $self->post_load;
1811}
1812
1813sub customise_for {
1814 my ($self, $ob) = @_;
1815
1816 return find "~" . $ob->name . "/" . $self->{path}
1817 if $self->per_player;
1818
1819# return find "?party/" . $ob->name . "/" . $self->{path}
1820# if $self->per_party;
1821
1822 $self
1823}
1824
1825# find and load all maps in the 3x3 area around a map
1826sub load_diag {
1827 my ($map) = @_;
1828
1829 my @diag; # diagonal neighbours
1830
1831 for (0 .. 3) {
1832 my $neigh = $map->tile_path ($_)
1833 or next;
1834 $neigh = find $neigh, $map
1835 or next;
1836 $neigh->load;
1837
1838 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1839 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1840 }
1841
1842 for (@diag) {
1843 my $neigh = find @$_
1844 or next;
1845 $neigh->load;
1846 }
1847}
1848
1849sub find_sync {
1276 my ($path, $origin) = @_; 1850 my ($path, $origin) = @_;
1277 1851
1278 #warn "load_map_sync<$path, $origin>\n";#d# 1852 cf::sync_job { find $path, $origin }
1853}
1279 1854
1280 cf::sync_job { 1855sub do_load_sync {
1281 my $map = cf::map::find_map $path, $origin 1856 my ($map) = @_;
1282 or return; 1857
1858 cf::sync_job { $map->load };
1859}
1860
1861our %MAP_PREFETCH;
1862our $MAP_PREFETCHER = undef;
1863
1864sub find_async {
1865 my ($path, $origin) = @_;
1866
1867 $path = normalise $path, $origin && $origin->{path};
1868
1869 if (my $map = $cf::MAP{$path}) {
1870 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1871 }
1872
1873 undef $MAP_PREFETCH{$path};
1874 $MAP_PREFETCHER ||= cf::async {
1875 while (%MAP_PREFETCH) {
1876 for my $path (keys %MAP_PREFETCH) {
1877 my $map = find $path
1878 or next;
1283 $map->load; 1879 $map->load;
1284 $map 1880
1881 delete $MAP_PREFETCH{$path};
1882 }
1883 }
1884 undef $MAP_PREFETCHER;
1285 } 1885 };
1886 $MAP_PREFETCHER->prio (6);
1887
1888 ()
1286} 1889}
1287 1890
1288sub save { 1891sub save {
1289 my ($self) = @_; 1892 my ($self) = @_;
1290 1893
1894 my $lock = cf::lock_acquire "map_data:" . $self->path;
1895
1291 $self->{last_save} = $cf::RUNTIME; 1896 $self->{last_save} = $cf::RUNTIME;
1292 1897
1293 return unless $self->dirty; 1898 return unless $self->dirty;
1294 1899
1295 my $save = $self->{path}->save_path; utf8::encode $save; 1900 my $save = $self->save_path; utf8::encode $save;
1296 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1901 my $uniq = $self->uniq_path; utf8::encode $uniq;
1297 1902
1298 $self->{load_path} = $save; 1903 $self->{load_path} = $save;
1299 1904
1300 return if $self->{deny_save}; 1905 return if $self->{deny_save};
1301 1906
1907 local $self->{last_access} = $self->last_access;#d#
1908
1909 cf::async {
1910 $_->contr->save for $self->players;
1911 };
1912
1302 if ($uniq) { 1913 if ($uniq) {
1303 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1914 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1304 $self->save_objects ($uniq, cf::IO_UNIQUES); 1915 $self->_save_objects ($uniq, cf::IO_UNIQUES);
1305 } else { 1916 } else {
1306 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 1917 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
1307 } 1918 }
1308} 1919}
1309 1920
1310sub swap_out { 1921sub swap_out {
1311 my ($self) = @_; 1922 my ($self) = @_;
1923
1924 # save first because save cedes
1925 $self->save;
1926
1927 my $lock = cf::lock_acquire "map_data:" . $self->path;
1312 1928
1313 return if $self->players; 1929 return if $self->players;
1314 return if $self->in_memory != cf::MAP_IN_MEMORY; 1930 return if $self->in_memory != cf::MAP_IN_MEMORY;
1315 return if $self->{deny_save}; 1931 return if $self->{deny_save};
1316 1932
1317 $self->save;
1318 $self->clear; 1933 $self->clear;
1319 $self->in_memory (cf::MAP_SWAPPED); 1934 $self->in_memory (cf::MAP_SWAPPED);
1320} 1935}
1321 1936
1322sub reset_at { 1937sub reset_at {
1323 my ($self) = @_; 1938 my ($self) = @_;
1324 1939
1325 # TODO: safety, remove and allow resettable per-player maps 1940 # TODO: safety, remove and allow resettable per-player maps
1326 return 1e99 if $self->{path}{user_rel};
1327 return 1e99 if $self->{deny_reset}; 1941 return 1e99 if $self->{deny_reset};
1328 1942
1329 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1943 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1330 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1944 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1331 1945
1336 my ($self) = @_; 1950 my ($self) = @_;
1337 1951
1338 $self->reset_at <= $cf::RUNTIME 1952 $self->reset_at <= $cf::RUNTIME
1339} 1953}
1340 1954
1341sub unlink_save {
1342 my ($self) = @_;
1343
1344 utf8::encode (my $save = $self->{path}->save_path);
1345 aioreq_pri 3; IO::AIO::aio_unlink $save;
1346 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1347}
1348
1349sub rename {
1350 my ($self, $new_path) = @_;
1351
1352 $self->unlink_save;
1353
1354 delete $cf::MAP{$self->path};
1355 $self->{path} = new cf::path $new_path;
1356 $self->path ($self->{path}->as_string);
1357 $cf::MAP{$self->path} = $self;
1358
1359 $self->save;
1360}
1361
1362sub reset { 1955sub reset {
1363 my ($self) = @_; 1956 my ($self) = @_;
1364 1957
1958 my $lock = cf::lock_acquire "map_data:$self->{path}";
1959
1365 return if $self->players; 1960 return if $self->players;
1366 return if $self->{path}{user_rel};#d#
1367 1961
1368 warn "resetting map ", $self->path;#d# 1962 warn "resetting map ", $self->path;
1963
1964 $self->in_memory (cf::MAP_SWAPPED);
1965
1966 # need to save uniques path
1967 unless ($self->{deny_save}) {
1968 my $uniq = $self->uniq_path; utf8::encode $uniq;
1969
1970 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1971 if $uniq;
1972 }
1369 1973
1370 delete $cf::MAP{$self->path}; 1974 delete $cf::MAP{$self->path};
1975
1976 $self->clear;
1371 1977
1372 $_->clear_links_to ($self) for values %cf::MAP; 1978 $_->clear_links_to ($self) for values %cf::MAP;
1373 1979
1374 $self->unlink_save; 1980 $self->unlink_save;
1375 $self->destroy; 1981 $self->destroy;
1378my $nuke_counter = "aaaa"; 1984my $nuke_counter = "aaaa";
1379 1985
1380sub nuke { 1986sub nuke {
1381 my ($self) = @_; 1987 my ($self) = @_;
1382 1988
1989 delete $cf::MAP{$self->path};
1990
1991 $self->unlink_save;
1992
1993 bless $self, "cf::map";
1994 delete $self->{deny_reset};
1383 $self->{deny_save} = 1; 1995 $self->{deny_save} = 1;
1384 $self->reset_timeout (1); 1996 $self->reset_timeout (1);
1385 $self->rename ("{nuke}/" . ($nuke_counter++)); 1997 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1998
1999 $cf::MAP{$self->path} = $self;
2000
1386 $self->reset; # polite request, might not happen 2001 $self->reset; # polite request, might not happen
1387} 2002}
1388 2003
1389sub customise_for { 2004=item $maps = cf::map::tmp_maps
1390 my ($map, $ob) = @_;
1391 2005
1392 if ($map->per_player) { 2006Returns an arrayref with all map paths of currently instantiated and saved
1393 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path}; 2007maps. May block.
2008
2009=cut
2010
2011sub tmp_maps() {
1394 } 2012 [
1395 2013 map {
1396 $map 2014 utf8::decode $_;
2015 /\.map$/
2016 ? normalise $_
2017 : ()
2018 } @{ aio_readdir $TMPDIR or [] }
2019 ]
1397} 2020}
1398 2021
1399sub emergency_save { 2022=item $maps = cf::map::random_maps
1400 local $cf::FREEZE = 1;
1401 2023
1402 warn "enter emergency map save\n"; 2024Returns an arrayref with all map paths of currently instantiated and saved
2025random maps. May block.
1403 2026
1404 cf::sync_job { 2027=cut
1405 warn "begin emergency map save\n";
1406 $_->save for values %cf::MAP;
1407 };
1408 2028
1409 warn "end emergency map save\n"; 2029sub random_maps() {
2030 [
2031 map {
2032 utf8::decode $_;
2033 /\.map$/
2034 ? normalise "?random/$_"
2035 : ()
2036 } @{ aio_readdir $RANDOMDIR or [] }
2037 ]
2038}
2039
2040=item cf::map::unique_maps
2041
2042Returns an arrayref of paths of all shared maps that have
2043instantiated unique items. May block.
2044
2045=cut
2046
2047sub unique_maps() {
2048 [
2049 map {
2050 utf8::decode $_;
2051 /\.map$/
2052 ? normalise $_
2053 : ()
2054 } @{ aio_readdir $UNIQUEDIR or [] }
2055 ]
1410} 2056}
1411 2057
1412package cf; 2058package cf;
1413 2059
1414=back 2060=back
1415 2061
2062=head3 cf::object
2063
2064=cut
2065
2066package cf::object;
2067
2068=over 4
2069
2070=item $ob->inv_recursive
2071
2072Returns the inventory of the object _and_ their inventories, recursively.
2073
2074=cut
2075
2076sub inv_recursive_;
2077sub inv_recursive_ {
2078 map { $_, inv_recursive_ $_->inv } @_
2079}
2080
2081sub inv_recursive {
2082 inv_recursive_ inv $_[0]
2083}
2084
2085package cf;
2086
2087=back
1416 2088
1417=head3 cf::object::player 2089=head3 cf::object::player
1418 2090
1419=over 4 2091=over 4
1420 2092
1434 2106
1435 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2107 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1436 2108
1437 if ($self->{record_replies}) { 2109 if ($self->{record_replies}) {
1438 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2110 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2111
1439 } else { 2112 } else {
2113 my $pl = $self->contr;
2114
2115 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2116 my $diag = $pl->{npc_dialog};
2117 $diag->{pl}->ext_reply (
2118 $diag->{id},
2119 msgtype => "reply",
2120 msg => $diag->{pl}->expand_cfpod ($msg),
2121 add_topics => []
2122 );
2123
2124 } else {
1440 $msg = $npc->name . " says: $msg" if $npc; 2125 $msg = $npc->name . " says: $msg" if $npc;
1441 $self->message ($msg, $flags); 2126 $self->message ($msg, $flags);
2127 }
1442 } 2128 }
1443} 2129}
1444 2130
1445=item $player_object->may ("access") 2131=item $player_object->may ("access")
1446 2132
1460 2146
1461=item $player_object->enter_link 2147=item $player_object->enter_link
1462 2148
1463Freezes the player and moves him/her to a special map (C<{link}>). 2149Freezes the player and moves him/her to a special map (C<{link}>).
1464 2150
1465The player should be reaosnably safe there for short amounts of time. You 2151The player should be reasonably safe there for short amounts of time. You
1466I<MUST> call C<leave_link> as soon as possible, though. 2152I<MUST> call C<leave_link> as soon as possible, though.
1467 2153
2154Will never block.
2155
1468=item $player_object->leave_link ($map, $x, $y) 2156=item $player_object->leave_link ($map, $x, $y)
1469 2157
1470Moves the player out of the specila link map onto the given map. If the 2158Moves the player out of the special C<{link}> map onto the specified
1471map is not valid (or omitted), the player will be moved back to the 2159map. If the map is not valid (or omitted), the player will be moved back
1472location he/she was before the call to C<enter_link>, or, if that fails, 2160to the location he/she was before the call to C<enter_link>, or, if that
1473to the emergency map position. 2161fails, to the emergency map position.
1474 2162
1475Might block. 2163Might block.
1476 2164
1477=cut 2165=cut
2166
2167sub link_map {
2168 unless ($LINK_MAP) {
2169 $LINK_MAP = cf::map::find "{link}"
2170 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
2171 $LINK_MAP->load;
2172 }
2173
2174 $LINK_MAP
2175}
1478 2176
1479sub cf::object::player::enter_link { 2177sub cf::object::player::enter_link {
1480 my ($self) = @_; 2178 my ($self) = @_;
1481 2179
1482 $self->deactivate_recursive; 2180 $self->deactivate_recursive;
1483 2181
1484 return if $self->map == $LINK_MAP; 2182 return if UNIVERSAL::isa $self->map, "ext::map_link";
1485 2183
1486 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2184 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1487 if $self->map; 2185 if $self->map && $self->map->{path} ne "{link}";
1488 2186
1489 $self->enter_map ($LINK_MAP, 20, 20); 2187 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1490} 2188}
1491 2189
1492sub cf::object::player::leave_link { 2190sub cf::object::player::leave_link {
1493 my ($self, $map, $x, $y) = @_; 2191 my ($self, $map, $x, $y) = @_;
2192
2193 return unless $self->contr->active;
1494 2194
1495 my $link_pos = delete $self->{_link_pos}; 2195 my $link_pos = delete $self->{_link_pos};
1496 2196
1497 unless ($map) { 2197 unless ($map) {
1498 # restore original map position 2198 # restore original map position
1499 ($map, $x, $y) = @{ $link_pos || [] }; 2199 ($map, $x, $y) = @{ $link_pos || [] };
1500 $map = cf::map::find_map $map; 2200 $map = cf::map::find $map;
1501 2201
1502 unless ($map) { 2202 unless ($map) {
1503 ($map, $x, $y) = @$EMERGENCY_POSITION; 2203 ($map, $x, $y) = @$EMERGENCY_POSITION;
1504 $map = cf::map::find_map $map 2204 $map = cf::map::find $map
1505 or die "FATAL: cannot load emergency map\n"; 2205 or die "FATAL: cannot load emergency map\n";
1506 } 2206 }
1507 } 2207 }
1508 2208
1509 ($x, $y) = (-1, -1) 2209 ($x, $y) = (-1, -1)
1512 # use -1 or undef as default coordinates, not 0, 0 2212 # use -1 or undef as default coordinates, not 0, 0
1513 ($x, $y) = ($map->enter_x, $map->enter_y) 2213 ($x, $y) = ($map->enter_x, $map->enter_y)
1514 if $x <=0 && $y <= 0; 2214 if $x <=0 && $y <= 0;
1515 2215
1516 $map->load; 2216 $map->load;
2217 $map->load_diag;
1517 2218
2219 return unless $self->contr->active;
1518 $self->activate_recursive; 2220 $self->activate_recursive;
2221
2222 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1519 $self->enter_map ($map, $x, $y); 2223 $self->enter_map ($map, $x, $y);
1520} 2224}
1521 2225
1522cf::player->attach (
1523 on_logout => sub {
1524 my ($pl) = @_;
1525
1526 # abort map switching before logout
1527 if ($pl->ob->{_link_pos}) {
1528 cf::sync_job {
1529 $pl->ob->leave_link
1530 };
1531 }
1532 },
1533 on_login => sub {
1534 my ($pl) = @_;
1535
1536 # try to abort aborted map switching on player login :)
1537 # should happen only on crashes
1538 if ($pl->ob->{_link_pos}) {
1539 $pl->ob->enter_link;
1540 Coro::async {
1541 # we need this sleep as the login has a concurrent enter_exit running
1542 # and this sleep increases chances of the player not ending up in scorn
1543 Coro::Timer::sleep 1;
1544 $pl->ob->leave_link;
1545 };
1546 }
1547 },
1548);
1549
1550=item $player_object->goto_map ($path, $x, $y) 2226=item $player_object->goto ($path, $x, $y[, $check->($map)])
1551 2227
1552=cut 2228Moves the player to the given map-path and coordinates by first freezing
2229her, loading and preparing them map, calling the provided $check callback
2230that has to return the map if sucecssful, and then unfreezes the player on
2231the new (success) or old (failed) map position.
1553 2232
2233=cut
2234
2235our $GOTOGEN;
2236
1554sub cf::object::player::goto_map { 2237sub cf::object::player::goto {
1555 my ($self, $path, $x, $y) = @_; 2238 my ($self, $path, $x, $y, $check) = @_;
2239
2240 # do generation counting so two concurrent goto's will be executed in-order
2241 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1556 2242
1557 $self->enter_link; 2243 $self->enter_link;
1558 2244
1559 (Coro::async { 2245 (async {
1560 $path = new cf::path $path; 2246 my $map = eval {
1561
1562 my $map = cf::map::find_map $path->as_string; 2247 my $map = cf::map::find $path;
2248
2249 if ($map) {
1563 $map = $map->customise_for ($self) if $map; 2250 $map = $map->customise_for ($self);
1564 2251 $map = $check->($map) if $check && $map;
1565# warn "entering ", $map->path, " at ($x, $y)\n" 2252 } else {
1566# if $map;
1567
1568 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2253 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2254 }
1569 2255
2256 $map
2257 };
2258
2259 if ($@) {
2260 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2261 LOG llevError | logBacktrace, Carp::longmess $@;
2262 }
2263
2264 if ($gen == $self->{_goto_generation}) {
2265 delete $self->{_goto_generation};
1570 $self->leave_link ($map, $x, $y); 2266 $self->leave_link ($map, $x, $y);
2267 }
1571 })->prio (1); 2268 })->prio (1);
1572} 2269}
1573 2270
1574=item $player_object->enter_exit ($exit_object) 2271=item $player_object->enter_exit ($exit_object)
1575 2272
1577 2274
1578sub parse_random_map_params { 2275sub parse_random_map_params {
1579 my ($spec) = @_; 2276 my ($spec) = @_;
1580 2277
1581 my $rmp = { # defaults 2278 my $rmp = { # defaults
1582 xsize => 10, 2279 xsize => (cf::rndm 15, 40),
1583 ysize => 10, 2280 ysize => (cf::rndm 15, 40),
2281 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2282 #layout => string,
1584 }; 2283 };
1585 2284
1586 for (split /\n/, $spec) { 2285 for (split /\n/, $spec) {
1587 my ($k, $v) = split /\s+/, $_, 2; 2286 my ($k, $v) = split /\s+/, $_, 2;
1588 2287
1592 $rmp 2291 $rmp
1593} 2292}
1594 2293
1595sub prepare_random_map { 2294sub prepare_random_map {
1596 my ($exit) = @_; 2295 my ($exit) = @_;
2296
2297 my $guard = cf::lock_acquire "exit_prepare:$exit";
1597 2298
1598 # all this does is basically replace the /! path by 2299 # all this does is basically replace the /! path by
1599 # a new random map path (?random/...) with a seed 2300 # a new random map path (?random/...) with a seed
1600 # that depends on the exit object 2301 # that depends on the exit object
1601 2302
1602 my $rmp = parse_random_map_params $exit->msg; 2303 my $rmp = parse_random_map_params $exit->msg;
1603 2304
1604 if ($exit->map) { 2305 if ($exit->map) {
1605 $rmp->{region} = $exit->map->region_name; 2306 $rmp->{region} = $exit->region->name;
1606 $rmp->{origin_map} = $exit->map->path; 2307 $rmp->{origin_map} = $exit->map->path;
1607 $rmp->{origin_x} = $exit->x; 2308 $rmp->{origin_x} = $exit->x;
1608 $rmp->{origin_y} = $exit->y; 2309 $rmp->{origin_y} = $exit->y;
1609 } 2310 }
1610 2311
1611 $rmp->{random_seed} ||= $exit->random_seed; 2312 $rmp->{random_seed} ||= $exit->random_seed;
1612 2313
1613 my $data = cf::to_json $rmp; 2314 my $data = cf::to_json $rmp;
1614 my $md5 = Digest::MD5::md5_hex $data; 2315 my $md5 = Digest::MD5::md5_hex $data;
2316 my $meta = "$RANDOMDIR/$md5.meta";
1615 2317
1616 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2318 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1617 aio_write $fh, 0, (length $data), $data, 0; 2319 aio_write $fh, 0, (length $data), $data, 0;
2320 undef $fh;
2321 aio_rename "$meta~", $meta;
1618 2322
1619 $exit->slaying ("?random/$md5"); 2323 $exit->slaying ("?random/$md5");
1620 $exit->msg (undef); 2324 $exit->msg (undef);
1621 } 2325 }
1622} 2326}
1624sub cf::object::player::enter_exit { 2328sub cf::object::player::enter_exit {
1625 my ($self, $exit) = @_; 2329 my ($self, $exit) = @_;
1626 2330
1627 return unless $self->type == cf::PLAYER; 2331 return unless $self->type == cf::PLAYER;
1628 2332
2333 if ($exit->slaying eq "/!") {
2334 #TODO: this should de-fi-ni-te-ly not be a sync-job
2335 # the problem is that $exit might not survive long enough
2336 # so it needs to be done right now, right here
2337 cf::sync_job { prepare_random_map $exit };
2338 }
2339
2340 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2341 my $hp = $exit->stats->hp;
2342 my $sp = $exit->stats->sp;
2343
1629 $self->enter_link; 2344 $self->enter_link;
1630 2345
1631 (Coro::async { 2346 (async {
2347 $self->deactivate_recursive; # just to be sure
1632 unless (eval { 2348 unless (eval {
1633 2349 $self->goto ($slaying, $hp, $sp);
1634 prepare_random_map $exit
1635 if $exit->slaying eq "/!";
1636
1637 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1638 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
1639 2350
1640 1; 2351 1;
1641 }) { 2352 }) {
1642 $self->message ("Something went wrong deep within the crossfire server. " 2353 $self->message ("Something went wrong deep within the crossfire server. "
1643 . "I'll try to bring you back to the map you were before. " 2354 . "I'll try to bring you back to the map you were before. "
1644 . "Please report this to the dungeon master", 2355 . "Please report this to the dungeon master!",
1645 cf::NDI_UNIQUE | cf::NDI_RED); 2356 cf::NDI_UNIQUE | cf::NDI_RED);
1646 2357
1647 warn "ERROR in enter_exit: $@"; 2358 warn "ERROR in enter_exit: $@";
1648 $self->leave_link; 2359 $self->leave_link;
1649 } 2360 }
1650 })->prio (1); 2361 })->prio (1);
1663 2374
1664sub cf::client::send_drawinfo { 2375sub cf::client::send_drawinfo {
1665 my ($self, $text, $flags) = @_; 2376 my ($self, $text, $flags) = @_;
1666 2377
1667 utf8::encode $text; 2378 utf8::encode $text;
1668 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2379 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1669} 2380}
1670 2381
2382=item $client->send_msg ($color, $type, $msg, [extra...])
2383
2384Send a drawinfo or msg packet to the client, formatting the msg for the
2385client if neccessary. C<$type> should be a string identifying the type of
2386the message, with C<log> being the default. If C<$color> is negative, suppress
2387the message unless the client supports the msg packet.
2388
2389=cut
2390
2391sub cf::client::send_msg {
2392 my ($self, $color, $type, $msg, @extra) = @_;
2393
2394 $msg = $self->pl->expand_cfpod ($msg);
2395
2396 if ($self->can_msg) {
2397 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2398 } else {
2399 # replace some tags by gcfclient-compatible ones
2400 for ($msg) {
2401 1 while
2402 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2403 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2404 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2405 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2406 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2407 }
2408
2409 if ($color >= 0) {
2410 if (0 && $msg =~ /\[/) {
2411 $self->send_packet ("drawextinfo $color 4 0 $msg")
2412 } else {
2413 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2414 $self->send_packet ("drawinfo $color $msg")
2415 }
2416 }
2417 }
2418}
2419
2420=item $client->ext_event ($type, %msg)
2421
2422Sends an ext event to the client.
2423
2424=cut
2425
2426sub cf::client::ext_event($$%) {
2427 my ($self, $type, %msg) = @_;
2428
2429 $msg{msgtype} = "event_$type";
2430 $self->send_packet ("ext " . cf::to_json \%msg);
2431}
1671 2432
1672=item $success = $client->query ($flags, "text", \&cb) 2433=item $success = $client->query ($flags, "text", \&cb)
1673 2434
1674Queues a query to the client, calling the given callback with 2435Queues a query to the client, calling the given callback with
1675the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2436the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1676C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2437C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
1677 2438
1678Queries can fail, so check the return code. Or don't, as queries will become 2439Queries can fail, so check the return code. Or don't, as queries will
1679reliable at some point in the future. 2440become reliable at some point in the future.
1680 2441
1681=cut 2442=cut
1682 2443
1683sub cf::client::query { 2444sub cf::client::query {
1684 my ($self, $flags, $text, $cb) = @_; 2445 my ($self, $flags, $text, $cb) = @_;
1692 utf8::encode $text; 2453 utf8::encode $text;
1693 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2454 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
1694 2455
1695 $self->send_packet ($self->{query_queue}[0][0]) 2456 $self->send_packet ($self->{query_queue}[0][0])
1696 if @{ $self->{query_queue} } == 1; 2457 if @{ $self->{query_queue} } == 1;
2458
2459 1
1697} 2460}
1698 2461
1699cf::client->attach ( 2462cf::client->attach (
1700 on_reply => sub { 2463 on_reply => sub {
1701 my ($ns, $msg) = @_; 2464 my ($ns, $msg) = @_;
1702 2465
1703 # this weird shuffling is so that direct followup queries 2466 # this weird shuffling is so that direct followup queries
1704 # get handled first 2467 # get handled first
1705 my $queue = delete $ns->{query_queue}; 2468 my $queue = delete $ns->{query_queue}
2469 or return; # be conservative, not sure how that can happen, but we saw a crash here
1706 2470
1707 (shift @$queue)->[1]->($msg); 2471 (shift @$queue)->[1]->($msg);
2472 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1708 2473
1709 push @{ $ns->{query_queue} }, @$queue; 2474 push @{ $ns->{query_queue} }, @$queue;
1710 2475
1711 if (@{ $ns->{query_queue} } == @$queue) { 2476 if (@{ $ns->{query_queue} } == @$queue) {
1712 if (@$queue) { 2477 if (@$queue) {
1714 } else { 2479 } else {
1715 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2480 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
1716 } 2481 }
1717 } 2482 }
1718 }, 2483 },
2484 on_exticmd => sub {
2485 my ($ns, $buf) = @_;
2486
2487 my $msg = eval { from_json $buf };
2488
2489 if (ref $msg) {
2490 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2491 if (my %reply = $cb->($ns, $msg)) {
2492 $reply{msgid} = $msg->{msgid};
2493 $ns->send ("ext " . cf::to_json \%reply);
2494 }
2495 }
2496 } else {
2497 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2498 }
2499
2500 cf::override;
2501 },
1719); 2502);
1720 2503
1721=item $client->coro (\&cb) 2504=item $client->async (\&cb)
1722 2505
1723Create a new coroutine, running the specified callback. The coroutine will 2506Create a new coroutine, running the specified callback. The coroutine will
1724be automatically cancelled when the client gets destroyed (e.g. on logout, 2507be automatically cancelled when the client gets destroyed (e.g. on logout,
1725or loss of connection). 2508or loss of connection).
1726 2509
1727=cut 2510=cut
1728 2511
1729sub cf::client::coro { 2512sub cf::client::async {
1730 my ($self, $cb) = @_; 2513 my ($self, $cb) = @_;
1731 2514
1732 my $coro; $coro = async { 2515 my $coro = &Coro::async ($cb);
1733 eval {
1734 $cb->();
1735 };
1736 warn $@ if $@;
1737 };
1738 2516
1739 $coro->on_destroy (sub { 2517 $coro->on_destroy (sub {
1740 delete $self->{_coro}{$coro+0}; 2518 delete $self->{_coro}{$coro+0};
1741 }); 2519 });
1742 2520
1775 2553
1776# here we export the classes and methods available to script code 2554# here we export the classes and methods available to script code
1777 2555
1778=pod 2556=pod
1779 2557
1780The following fucntions and emthods are available within a safe environment: 2558The following functions and methods are available within a safe environment:
1781 2559
1782 cf::object contr pay_amount pay_player map 2560 cf::object contr pay_amount pay_player map
1783 cf::object::player player 2561 cf::object::player player
1784 cf::player peaceful 2562 cf::player peaceful
1785 cf::map trigger 2563 cf::map trigger
1866=back 2644=back
1867 2645
1868=cut 2646=cut
1869 2647
1870############################################################################# 2648#############################################################################
2649# the server's init and main functions
1871 2650
1872=head2 EXTENSION DATABASE SUPPORT 2651sub load_facedata($) {
2652 my ($path) = @_;
1873 2653
1874Crossfire maintains a very simple database for extension use. It can 2654 warn "loading facedata from $path\n";
1875currently store anything that can be serialised using Storable, which
1876excludes objects.
1877 2655
1878The parameter C<$family> should best start with the name of the extension 2656 my $facedata;
1879using it, it should be unique. 2657 0 < aio_load $path, $facedata
2658 or die "$path: $!";
1880 2659
1881=over 4 2660 $facedata = Coro::Storable::thaw $facedata;
1882 2661
1883=item $hashref = cf::db_get $family 2662 $facedata->{version} == 2
2663 or cf::cleanup "$path: version mismatch, cannot proceed.";
1884 2664
1885Return a hashref for use by the extension C<$family>, which can be
1886modified. After modifications, you have to call C<cf::db_dirty> or
1887C<cf::db_sync>.
1888
1889=item $value = cf::db_get $family => $key
1890
1891Returns a single value from the database
1892
1893=item cf::db_put $family => $hashref
1894
1895Stores the given family hashref into the database. Updates are delayed, if
1896you want the data to be synced to disk immediately, use C<cf::db_sync>.
1897
1898=item cf::db_put $family => $key => $value
1899
1900Stores the given C<$value> in the family hash. Updates are delayed, if you
1901want the data to be synced to disk immediately, use C<cf::db_sync>.
1902
1903=item cf::db_dirty
1904
1905Marks the database as dirty, to be updated at a later time.
1906
1907=item cf::db_sync
1908
1909Immediately write the database to disk I<if it is dirty>.
1910
1911=cut
1912
1913our $DB;
1914
1915{
1916 my $path = cf::localdir . "/database.pst";
1917
1918 sub db_load() {
1919 $DB = stat $path ? Storable::retrieve $path : { };
1920 } 2665 {
2666 my $faces = $facedata->{faceinfo};
1921 2667
1922 my $pid; 2668 while (my ($face, $info) = each %$faces) {
1923 2669 my $idx = (cf::face::find $face) || cf::face::alloc $face;
1924 sub db_save() { 2670 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
1925 waitpid $pid, 0 if $pid; 2671 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
1926 if (0 == ($pid = fork)) { 2672 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
1927 $DB->{_meta}{version} = 1; 2673 Coro::cede;
1928 Storable::nstore $DB, "$path~";
1929 rename "$path~", $path;
1930 cf::_exit 0 if defined $pid;
1931 }
1932 }
1933
1934 my $dirty;
1935
1936 sub db_sync() {
1937 db_save if $dirty;
1938 undef $dirty;
1939 }
1940
1941 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
1942 db_sync;
1943 });
1944
1945 sub db_dirty() {
1946 $dirty = 1;
1947 $idle->start;
1948 }
1949
1950 sub db_get($;$) {
1951 @_ >= 2
1952 ? $DB->{$_[0]}{$_[1]}
1953 : ($DB->{$_[0]} ||= { })
1954 }
1955
1956 sub db_put($$;$) {
1957 if (@_ >= 3) {
1958 $DB->{$_[0]}{$_[1]} = $_[2];
1959 } else {
1960 $DB->{$_[0]} = $_[1];
1961 }
1962 db_dirty;
1963 }
1964
1965 cf::global->attach (
1966 prio => 10000,
1967 on_cleanup => sub {
1968 db_sync;
1969 }, 2674 }
1970 );
1971}
1972 2675
1973############################################################################# 2676 while (my ($face, $info) = each %$faces) {
1974# the server's main() 2677 next unless $info->{smooth};
2678 my $idx = cf::face::find $face
2679 or next;
2680 if (my $smooth = cf::face::find $info->{smooth}) {
2681 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2682 } else {
2683 warn "smooth face '$info->{smooth}' not found for face '$face'";
2684 }
2685 Coro::cede;
2686 }
2687 }
2688
2689 {
2690 my $anims = $facedata->{animinfo};
2691
2692 while (my ($anim, $info) = each %$anims) {
2693 cf::anim::set $anim, $info->{frames}, $info->{facings};
2694 Coro::cede;
2695 }
2696
2697 cf::anim::invalidate_all; # d'oh
2698 }
2699
2700 1
2701}
2702
2703sub reload_regions {
2704 load_resource_file "$MAPDIR/regions"
2705 or die "unable to load regions file\n";
2706}
2707
2708sub reload_facedata {
2709 load_facedata "$DATADIR/facedata"
2710 or die "unable to load facedata\n";
2711}
2712
2713sub reload_archetypes {
2714 load_resource_file "$DATADIR/archetypes"
2715 or die "unable to load archetypes\n";
2716}
2717
2718sub reload_treasures {
2719 load_resource_file "$DATADIR/treasures"
2720 or die "unable to load treasurelists\n";
2721}
2722
2723sub reload_resources {
2724 warn "reloading resource files...\n";
2725
2726 reload_regions;
2727 reload_facedata;
2728 #reload_archetypes;#d#
2729 reload_archetypes;
2730 reload_treasures;
2731
2732 warn "finished reloading resource files\n";
2733}
2734
2735sub init {
2736 reload_resources;
2737}
1975 2738
1976sub cfg_load { 2739sub cfg_load {
1977 open my $fh, "<:utf8", cf::confdir . "/config" 2740 open my $fh, "<:utf8", "$CONFDIR/config"
1978 or return; 2741 or return;
1979 2742
1980 local $/; 2743 local $/;
1981 *CFG = YAML::Syck::Load <$fh>; 2744 *CFG = YAML::Syck::Load <$fh>;
2745
2746 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2747
2748 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2749 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2750
2751 if (exists $CFG{mlockall}) {
2752 eval {
2753 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2754 and die "WARNING: m(un)lockall failed: $!\n";
2755 };
2756 warn $@ if $@;
2757 }
1982} 2758}
1983 2759
1984sub main { 2760sub main {
1985 # we must not ever block the main coroutine 2761 # we must not ever block the main coroutine
1986 local $Coro::idle = sub { 2762 local $Coro::idle = sub {
1987 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2763 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1988 (Coro::unblock_sub { 2764 (async {
1989 Event::one_event; 2765 Event::one_event;
1990 })->(); 2766 })->prio (Coro::PRIO_MAX);
1991 }; 2767 };
1992 2768
1993 cfg_load; 2769 cfg_load;
1994 db_load; 2770 db_init;
1995 load_extensions; 2771 load_extensions;
2772
2773 $TICK_WATCHER->start;
1996 Event::loop; 2774 Event::loop;
1997} 2775}
1998 2776
1999############################################################################# 2777#############################################################################
2000# initialisation 2778# initialisation and cleanup
2001 2779
2780# install some emergency cleanup handlers
2781BEGIN {
2782 for my $signal (qw(INT HUP TERM)) {
2783 Event->signal (
2784 reentrant => 0,
2785 data => WF_AUTOCANCEL,
2786 signal => $signal,
2787 prio => 0,
2788 cb => sub {
2789 cf::cleanup "SIG$signal";
2790 },
2791 );
2792 }
2793}
2794
2795sub write_runtime {
2796 my $runtime = "$LOCALDIR/runtime";
2797
2798 # first touch the runtime file to show we are still running:
2799 # the fsync below can take a very very long time.
2800
2801 IO::AIO::aio_utime $runtime, undef, undef;
2802
2803 my $guard = cf::lock_acquire "write_runtime";
2804
2805 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2806 or return;
2807
2808 my $value = $cf::RUNTIME + 90 + 10;
2809 # 10 is the runtime save interval, for a monotonic clock
2810 # 60 allows for the watchdog to kill the server.
2811
2812 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2813 and return;
2814
2815 # always fsync - this file is important
2816 aio_fsync $fh
2817 and return;
2818
2819 # touch it again to show we are up-to-date
2820 aio_utime $fh, undef, undef;
2821
2822 close $fh
2823 or return;
2824
2825 aio_rename "$runtime~", $runtime
2826 and return;
2827
2828 warn "runtime file written.\n";
2829
2830 1
2831}
2832
2833sub emergency_save() {
2834 my $freeze_guard = cf::freeze_mainloop;
2835
2836 warn "enter emergency perl save\n";
2837
2838 cf::sync_job {
2839 # use a peculiar iteration method to avoid tripping on perl
2840 # refcount bugs in for. also avoids problems with players
2841 # and maps saved/destroyed asynchronously.
2842 warn "begin emergency player save\n";
2843 for my $login (keys %cf::PLAYER) {
2844 my $pl = $cf::PLAYER{$login} or next;
2845 $pl->valid or next;
2846 $pl->save;
2847 }
2848 warn "end emergency player save\n";
2849
2850 warn "begin emergency map save\n";
2851 for my $path (keys %cf::MAP) {
2852 my $map = $cf::MAP{$path} or next;
2853 $map->valid or next;
2854 $map->save;
2855 }
2856 warn "end emergency map save\n";
2857
2858 warn "begin emergency database checkpoint\n";
2859 BDB::db_env_txn_checkpoint $DB_ENV;
2860 warn "end emergency database checkpoint\n";
2861 };
2862
2863 warn "leave emergency perl save\n";
2864}
2865
2866sub post_cleanup {
2867 my ($make_core) = @_;
2868
2869 warn Carp::longmess "post_cleanup backtrace"
2870 if $make_core;
2871}
2872
2002sub reload() { 2873sub do_reload_perl() {
2003 # can/must only be called in main 2874 # can/must only be called in main
2004 if ($Coro::current != $Coro::main) { 2875 if ($Coro::current != $Coro::main) {
2005 warn "can only reload from main coroutine\n"; 2876 warn "can only reload from main coroutine";
2006 return; 2877 return;
2007 } 2878 }
2008 2879
2009 warn "reloading..."; 2880 warn "reloading...";
2010 2881
2011 local $FREEZE = 1; 2882 warn "entering sync_job";
2883
2884 cf::sync_job {
2885 cf::write_runtime; # external watchdog should not bark
2012 cf::emergency_save; 2886 cf::emergency_save;
2887 cf::write_runtime; # external watchdog should not bark
2013 2888
2014 eval { 2889 warn "syncing database to disk";
2890 BDB::db_env_txn_checkpoint $DB_ENV;
2891
2015 # if anything goes wrong in here, we should simply crash as we already saved 2892 # if anything goes wrong in here, we should simply crash as we already saved
2016 2893
2017 # cancel all watchers 2894 warn "cancelling all WF_AUTOCANCEL watchers";
2018 for (Event::all_watchers) { 2895 for (Event::all_watchers) {
2019 $_->cancel if $_->data & WF_AUTOCANCEL; 2896 $_->cancel if $_->data & WF_AUTOCANCEL;
2020 } 2897 }
2021 2898
2899 warn "flushing outstanding aio requests";
2900 for (;;) {
2901 BDB::flush;
2902 IO::AIO::flush;
2903 Coro::cede;
2904 last unless IO::AIO::nreqs || BDB::nreqs;
2905 warn "iterate...";
2906 }
2907
2908 ++$RELOAD;
2909
2022 # cancel all extension coros 2910 warn "cancelling all extension coros";
2023 $_->cancel for values %EXT_CORO; 2911 $_->cancel for values %EXT_CORO;
2024 %EXT_CORO = (); 2912 %EXT_CORO = ();
2025 2913
2026 # unload all extensions 2914 warn "removing commands";
2027 for (@exts) { 2915 %COMMAND = ();
2916
2917 warn "removing ext/exti commands";
2918 %EXTCMD = ();
2919 %EXTICMD = ();
2920
2921 warn "unloading/nuking all extensions";
2922 for my $pkg (@EXTS) {
2028 warn "unloading <$_>"; 2923 warn "... unloading $pkg";
2029 unload_extension $_; 2924
2925 if (my $cb = $pkg->can ("unload")) {
2926 eval {
2927 $cb->($pkg);
2928 1
2929 } or warn "$pkg unloaded, but with errors: $@";
2030 } 2930 }
2031 2931
2932 warn "... nuking $pkg";
2933 Symbol::delete_package $pkg;
2934 }
2935
2032 # unload all modules loaded from $LIBDIR 2936 warn "unloading all perl modules loaded from $LIBDIR";
2033 while (my ($k, $v) = each %INC) { 2937 while (my ($k, $v) = each %INC) {
2034 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2938 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2035 2939
2036 warn "removing <$k>"; 2940 warn "... unloading $k";
2037 delete $INC{$k}; 2941 delete $INC{$k};
2038 2942
2039 $k =~ s/\.pm$//; 2943 $k =~ s/\.pm$//;
2040 $k =~ s/\//::/g; 2944 $k =~ s/\//::/g;
2041 2945
2044 } 2948 }
2045 2949
2046 Symbol::delete_package $k; 2950 Symbol::delete_package $k;
2047 } 2951 }
2048 2952
2049 # sync database to disk
2050 cf::db_sync;
2051 IO::AIO::flush;
2052
2053 # get rid of safe::, as good as possible 2953 warn "getting rid of safe::, as good as possible";
2054 Symbol::delete_package "safe::$_" 2954 Symbol::delete_package "safe::$_"
2055 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2955 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2056 2956
2057 # remove register_script_function callbacks
2058 # TODO
2059
2060 # unload cf.pm "a bit" 2957 warn "unloading cf.pm \"a bit\"";
2061 delete $INC{"cf.pm"}; 2958 delete $INC{"cf.pm"};
2959 delete $INC{"cf/pod.pm"};
2062 2960
2063 # don't, removes xs symbols, too, 2961 # don't, removes xs symbols, too,
2064 # and global variables created in xs 2962 # and global variables created in xs
2065 #Symbol::delete_package __PACKAGE__; 2963 #Symbol::delete_package __PACKAGE__;
2066 2964
2067 # reload cf.pm 2965 warn "unload completed, starting to reload now";
2966
2068 warn "reloading cf.pm"; 2967 warn "reloading cf.pm";
2069 require cf; 2968 require cf;
2070 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2969 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2071 2970
2072 # load config and database again 2971 warn "loading config and database again";
2073 cf::cfg_load; 2972 cf::cfg_load;
2074 cf::db_load;
2075 2973
2076 # load extensions
2077 warn "load extensions"; 2974 warn "loading extensions";
2078 cf::load_extensions; 2975 cf::load_extensions;
2079 2976
2080 # reattach attachments to objects 2977 warn "reattaching attachments to objects/players";
2081 warn "reattach"; 2978 _global_reattach; # objects, sockets
2082 _global_reattach; 2979 warn "reattaching attachments to maps";
2083 }; 2980 reattach $_ for values %MAP;
2981 warn "reattaching attachments to players";
2982 reattach $_ for values %PLAYER;
2084 2983
2085 if ($@) { 2984 warn "leaving sync_job";
2985
2986 1
2987 } or do {
2086 warn $@; 2988 warn $@;
2087 warn "error while reloading, exiting."; 2989 warn "error while reloading, exiting.";
2088 exit 1; 2990 exit 1;
2089 } 2991 };
2090 2992
2091 warn "reloaded successfully"; 2993 warn "reloaded";
2092}; 2994};
2093 2995
2094############################################################################# 2996our $RELOAD_WATCHER; # used only during reload
2095 2997
2096unless ($LINK_MAP) { 2998sub reload_perl() {
2097 $LINK_MAP = cf::map::new; 2999 # doing reload synchronously and two reloads happen back-to-back,
3000 # coro crashes during coro_state_free->destroy here.
2098 3001
2099 $LINK_MAP->width (41); 3002 $RELOAD_WATCHER ||= Event->timer (
2100 $LINK_MAP->height (41); 3003 reentrant => 0,
2101 $LINK_MAP->alloc;
2102 $LINK_MAP->path ("{link}");
2103 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2104 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2105
2106 # dirty hack because... archetypes are not yet loaded
2107 Event->timer (
2108 after => 2, 3004 after => 0,
3005 data => WF_AUTOCANCEL,
2109 cb => sub { 3006 cb => sub {
2110 $_[0]->w->cancel; 3007 do_reload_perl;
2111 3008 undef $RELOAD_WATCHER;
2112 # provide some exits "home"
2113 my $exit = cf::object::new "exit";
2114
2115 $exit->slaying ($EMERGENCY_POSITION->[0]);
2116 $exit->stats->hp ($EMERGENCY_POSITION->[1]);
2117 $exit->stats->sp ($EMERGENCY_POSITION->[2]);
2118
2119 $LINK_MAP->insert ($exit->clone, 19, 19);
2120 $LINK_MAP->insert ($exit->clone, 19, 20);
2121 $LINK_MAP->insert ($exit->clone, 19, 21);
2122 $LINK_MAP->insert ($exit->clone, 20, 19);
2123 $LINK_MAP->insert ($exit->clone, 20, 21);
2124 $LINK_MAP->insert ($exit->clone, 21, 19);
2125 $LINK_MAP->insert ($exit->clone, 21, 20);
2126 $LINK_MAP->insert ($exit->clone, 21, 21);
2127
2128 $exit->destroy;
2129 }); 3009 },
2130 3010 );
2131 $LINK_MAP->{deny_save} = 1;
2132 $LINK_MAP->{deny_reset} = 1;
2133
2134 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2135} 3011}
2136
2137register "<global>", __PACKAGE__;
2138 3012
2139register_command "reload" => sub { 3013register_command "reload" => sub {
2140 my ($who, $arg) = @_; 3014 my ($who, $arg) = @_;
2141 3015
2142 if ($who->flag (FLAG_WIZ)) { 3016 if ($who->flag (FLAG_WIZ)) {
2143 $who->message ("start of reload.");
2144 reload;
2145 $who->message ("end of reload."); 3017 $who->message ("reloading server.");
3018 async { reload_perl };
2146 } 3019 }
2147}; 3020};
2148 3021
2149unshift @INC, $LIBDIR; 3022unshift @INC, $LIBDIR;
2150 3023
3024my $bug_warning = 0;
3025
3026our @WAIT_FOR_TICK;
3027our @WAIT_FOR_TICK_BEGIN;
3028
3029sub wait_for_tick {
3030 return unless $TICK_WATCHER->is_active;
3031 return if $Coro::current == $Coro::main;
3032
3033 my $signal = new Coro::Signal;
3034 push @WAIT_FOR_TICK, $signal;
3035 $signal->wait;
3036}
3037
3038sub wait_for_tick_begin {
3039 return unless $TICK_WATCHER->is_active;
3040 return if $Coro::current == $Coro::main;
3041
3042 my $signal = new Coro::Signal;
3043 push @WAIT_FOR_TICK_BEGIN, $signal;
3044 $signal->wait;
3045}
3046
3047 my $min = 1e6;#d#
3048 my $avg = 10;
2151$TICK_WATCHER = Event->timer ( 3049$TICK_WATCHER = Event->timer (
2152 reentrant => 0, 3050 reentrant => 0,
3051 parked => 1,
2153 prio => 0, 3052 prio => 0,
2154 at => $NEXT_TICK || $TICK, 3053 at => $NEXT_TICK || $TICK,
2155 data => WF_AUTOCANCEL, 3054 data => WF_AUTOCANCEL,
2156 cb => sub { 3055 cb => sub {
2157 unless ($FREEZE) { 3056 if ($Coro::current != $Coro::main) {
3057 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3058 unless ++$bug_warning > 10;
3059 return;
3060 }
3061
3062 $NOW = $tick_start = Event::time;
3063
2158 cf::server_tick; # one server iteration 3064 cf::server_tick; # one server iteration
2159 $RUNTIME += $TICK; 3065
3066 0 && sync_job {#d#
3067 for(1..10) {
3068 my $t = Event::time;
3069 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3070 or die;
3071
3072 $map->width (50);
3073 $map->height (50);
3074 $map->alloc;
3075 $map->_load_objects ("/tmp/x.map", 1);
3076 my $t = Event::time - $t;
3077
3078 #next unless $t < 0.0013;#d#
3079 if ($t < $min) {
3080 $min = $t;
3081 }
3082 $avg = $avg * 0.99 + $t * 0.01;
3083 }
3084 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3085 exit 0;
3086 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2160 } 3087 };
2161 3088
3089 $RUNTIME += $TICK;
2162 $NEXT_TICK += $TICK; 3090 $NEXT_TICK += $TICK;
2163 3091
3092 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3093 $NEXT_RUNTIME_WRITE = $NOW + 10;
3094 Coro::async_pool {
3095 write_runtime
3096 or warn "ERROR: unable to write runtime file: $!";
3097 };
3098 }
3099
3100# my $AFTER = Event::time;
3101# warn $AFTER - $NOW;#d#
3102
3103 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3104 $sig->send;
3105 }
3106 while (my $sig = shift @WAIT_FOR_TICK) {
3107 $sig->send;
3108 }
3109
3110 $NOW = Event::time;
3111
2164 # if we are delayed by four ticks or more, skip them all 3112 # if we are delayed by four ticks or more, skip them all
2165 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3113 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2166 3114
2167 $TICK_WATCHER->at ($NEXT_TICK); 3115 $TICK_WATCHER->at ($NEXT_TICK);
2168 $TICK_WATCHER->start; 3116 $TICK_WATCHER->start;
3117
3118 $LOAD = ($NOW - $tick_start) / $TICK;
3119 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3120
3121 _post_tick;
3122
3123
2169 }, 3124 },
2170); 3125);
2171 3126
3127{
2172IO::AIO::max_poll_time $TICK * 0.2; 3128 BDB::max_poll_time $TICK * 0.1;
2173 3129 $BDB_POLL_WATCHER = Event->io (
2174Event->io ( 3130 reentrant => 0,
2175 fd => IO::AIO::poll_fileno, 3131 fd => BDB::poll_fileno,
2176 poll => 'r', 3132 poll => 'r',
2177 prio => 5, 3133 prio => 0,
2178 data => WF_AUTOCANCEL,
2179 cb => \&IO::AIO::poll_cb,
2180);
2181
2182Event->timer (
2183 data => WF_AUTOCANCEL, 3134 data => WF_AUTOCANCEL,
2184 after => 0, 3135 cb => \&BDB::poll_cb,
2185 interval => 10, 3136 );
2186 cb => sub { 3137 BDB::min_parallel 8;
2187 (Coro::unblock_sub { 3138
2188 write_runtime 3139 BDB::set_sync_prepare {
2189 or warn "ERROR: unable to write runtime file: $!"; 3140 my $status;
3141 my $current = $Coro::current;
3142 (
3143 sub {
3144 $status = $!;
3145 $current->ready; undef $current;
3146 },
3147 sub {
3148 Coro::schedule while defined $current;
3149 $! = $status;
3150 },
3151 )
3152 };
3153
3154 unless ($DB_ENV) {
3155 $DB_ENV = BDB::db_env_create;
3156
3157 cf::sync_job {
3158 eval {
3159 BDB::db_env_open
3160 $DB_ENV,
3161 $BDBDIR,
3162 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3163 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3164 0666;
3165
3166 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3167
3168 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3169 $DB_ENV->set_lk_detect;
3170 };
3171
3172 cf::cleanup "db_env_open(db): $@" if $@;
2190 })->(); 3173 };
2191 }, 3174 }
2192); 3175}
3176
3177{
3178 IO::AIO::min_parallel 8;
3179
3180 undef $Coro::AIO::WATCHER;
3181 IO::AIO::max_poll_time $TICK * 0.1;
3182 $AIO_POLL_WATCHER = Event->io (
3183 reentrant => 0,
3184 data => WF_AUTOCANCEL,
3185 fd => IO::AIO::poll_fileno,
3186 poll => 'r',
3187 prio => 6,
3188 cb => \&IO::AIO::poll_cb,
3189 );
3190}
3191
3192my $_log_backtrace;
3193
3194sub _log_backtrace {
3195 my ($msg, @addr) = @_;
3196
3197 $msg =~ s/\n//;
3198
3199 # limit the # of concurrent backtraces
3200 if ($_log_backtrace < 2) {
3201 ++$_log_backtrace;
3202 async {
3203 my @bt = fork_call {
3204 @addr = map { sprintf "%x", $_ } @addr;
3205 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3206 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3207 or die "addr2line: $!";
3208
3209 my @funcs;
3210 my @res = <$fh>;
3211 chomp for @res;
3212 while (@res) {
3213 my ($func, $line) = splice @res, 0, 2, ();
3214 push @funcs, "[$func] $line";
3215 }
3216
3217 @funcs
3218 };
3219
3220 LOG llevInfo, "[ABT] $msg\n";
3221 LOG llevInfo, "[ABT] $_\n" for @bt;
3222 --$_log_backtrace;
3223 };
3224 } else {
3225 LOG llevInfo, "[ABT] $msg\n";
3226 LOG llevInfo, "[ABT] [suppressed]\n";
3227 }
3228}
3229
3230# load additional modules
3231use cf::pod;
3232
3233END { cf::emergency_save }
2193 3234
21941 32351
2195 3236

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines