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.271 by root, Fri Jun 1 06:04:08 2007 UTC vs.
Revision 1.379 by root, Thu Oct 4 23:59:07 2007 UTC

… …
10use Event; 10use Event;
11use Opcode; 11use Opcode;
12use Safe; 12use Safe;
13use Safe::Hole; 13use Safe::Hole;
14 14
15use Coro 3.61 (); 15use Coro 3.64 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::Event;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable; 23use Coro::Storable;
24use Coro::Util ();
24 25
26use JSON::XS ();
25use BDB (); 27use BDB ();
26use Data::Dumper; 28use Data::Dumper;
27use Digest::MD5; 29use Digest::MD5;
28use Fcntl; 30use Fcntl;
29use YAML::Syck (); 31use YAML::Syck ();
30use IO::AIO 2.32 (); 32use IO::AIO 2.32 ();
31use Time::HiRes; 33use Time::HiRes;
32use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 ();
33 36
34# configure various modules to our taste 37# configure various modules to our taste
35# 38#
36$Storable::canonical = 1; # reduce rsync transfers 39$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
… …
49our %COMMAND = (); 52our %COMMAND = ();
50our %COMMAND_TIME = (); 53our %COMMAND_TIME = ();
51 54
52our @EXTS = (); # list of extension package names 55our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 56our %EXTCMD = ();
57our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 58our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 59our %EXT_MAP = (); # pluggable maps
56 60
57our $RELOAD; # number of reloads so far 61our $RELOAD; # number of reloads so far
58our @EVENT; 62our @EVENT;
… …
76our $NEXT_TICK; 80our $NEXT_TICK;
77our $NOW; 81our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 82our $USE_FSYNC = 1; # use fsync to write maps - default off
79 83
80our $BDB_POLL_WATCHER; 84our $BDB_POLL_WATCHER;
85our $BDB_DEADLOCK_WATCHER;
86our $BDB_CHECKPOINT_WATCHER;
87our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 88our $DB_ENV;
82 89
83our %CFG; 90our %CFG;
84 91
85our $UPTIME; $UPTIME ||= time; 92our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 93our $RUNTIME;
87 94
88our %PLAYER; # all users 95our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 96our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 97our $LINK_MAP; # the special {link} map, which is always available
91 98
92# used to convert map paths into valid unix filenames by replacing / by ∕ 99# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 100our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 101
… …
164 171
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 172These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166returns directly I<after> the tick processing (and consequently, can only wake one process 173returns directly I<after> the tick processing (and consequently, can only wake one process
167per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 174per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168 175
176=item @cf::INVOKE_RESULTS
177
178This array contains the results of the last C<invoke ()> call. When
179C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
180that call.
181
169=back 182=back
170 183
171=cut 184=cut
172 185
173BEGIN { 186BEGIN {
… …
177 $msg .= "\n" 190 $msg .= "\n"
178 unless $msg =~ /\n$/; 191 unless $msg =~ /\n$/;
179 192
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 193 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181 194
182 utf8::encode $msg;
183 LOG llevError, $msg; 195 LOG llevError, $msg;
184 }; 196 };
185} 197}
186 198
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 199@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 200@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 201@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 202@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 203@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
204@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
192@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 205@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
193 206
194# we bless all objects into (empty) derived classes to force a method lookup 207# we bless all objects into (empty) derived classes to force a method lookup
195# within the Safe compartment. 208# within the Safe compartment.
196for my $pkg (qw( 209for my $pkg (qw(
197 cf::global cf::attachable 210 cf::global cf::attachable
… …
205} 218}
206 219
207$Event::DIED = sub { 220$Event::DIED = sub {
208 warn "error in event callback: @_"; 221 warn "error in event callback: @_";
209}; 222};
223
224#############################################################################
210 225
211=head2 UTILITY FUNCTIONS 226=head2 UTILITY FUNCTIONS
212 227
213=over 4 228=over 4
214 229
… …
233 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 248 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
234 $d 249 $d
235 } || "[unable to dump $_[0]: '$@']"; 250 } || "[unable to dump $_[0]: '$@']";
236} 251}
237 252
238use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
239
240=item $ref = cf::from_json $json 253=item $ref = cf::from_json $json
241 254
242Converts a JSON string into the corresponding perl data structure. 255Converts a JSON string into the corresponding perl data structure.
243 256
244=item $json = cf::to_json $ref 257=item $json = cf::to_json $ref
245 258
246Converts a perl data structure into its JSON representation. 259Converts a perl data structure into its JSON representation.
260
261=cut
262
263our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
264
265sub to_json ($) { $json_coder->encode ($_[0]) }
266sub from_json ($) { $json_coder->decode ($_[0]) }
247 267
248=item cf::lock_wait $string 268=item cf::lock_wait $string
249 269
250Wait until the given lock is available. See cf::lock_acquire. 270Wait until the given lock is available. See cf::lock_acquire.
251 271
… …
254Wait until the given lock is available and then acquires it and returns 274Wait until the given lock is available and then acquires it and returns
255a Coro::guard object. If the guard object gets destroyed (goes out of scope, 275a Coro::guard object. If the guard object gets destroyed (goes out of scope,
256for example when the coroutine gets canceled), the lock is automatically 276for example when the coroutine gets canceled), the lock is automatically
257returned. 277returned.
258 278
279Locks are *not* recursive, locking from the same coro twice results in a
280deadlocked coro.
281
259Lock names should begin with a unique identifier (for example, cf::map::find 282Lock names should begin with a unique identifier (for example, cf::map::find
260uses map_find and cf::map::load uses map_load). 283uses map_find and cf::map::load uses map_load).
261 284
262=item $locked = cf::lock_active $string 285=item $locked = cf::lock_active $string
263 286
264Return true if the lock is currently active, i.e. somebody has locked it. 287Return true if the lock is currently active, i.e. somebody has locked it.
265 288
266=cut 289=cut
267 290
268our %LOCK; 291our %LOCK;
292our %LOCKER;#d#
269 293
270sub lock_wait($) { 294sub lock_wait($) {
271 my ($key) = @_; 295 my ($key) = @_;
296
297 if ($LOCKER{$key} == $Coro::current) {#d#
298 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
299 return;#d#
300 }#d#
272 301
273 # wait for lock, if any 302 # wait for lock, if any
274 while ($LOCK{$key}) { 303 while ($LOCK{$key}) {
275 push @{ $LOCK{$key} }, $Coro::current; 304 push @{ $LOCK{$key} }, $Coro::current;
276 Coro::schedule; 305 Coro::schedule;
… …
282 311
283 # wait, to be sure we are not locked 312 # wait, to be sure we are not locked
284 lock_wait $key; 313 lock_wait $key;
285 314
286 $LOCK{$key} = []; 315 $LOCK{$key} = [];
316 $LOCKER{$key} = $Coro::current;#d#
287 317
288 Coro::guard { 318 Coro::guard {
319 delete $LOCKER{$key};#d#
289 # wake up all waiters, to be on the safe side 320 # wake up all waiters, to be on the safe side
290 $_->ready for @{ delete $LOCK{$key} }; 321 $_->ready for @{ delete $LOCK{$key} };
291 } 322 }
292} 323}
293 324
… …
305 }; 336 };
306 $TICK_WATCHER->stop; 337 $TICK_WATCHER->stop;
307 $guard 338 $guard
308} 339}
309 340
341=item cf::get_slot $time[, $priority[, $name]]
342
343Allocate $time seconds of blocking CPU time at priority C<$priority>:
344This call blocks and returns only when you have at least C<$time> seconds
345of cpu time till the next tick. The slot is only valid till the next cede.
346
347The optional C<$name> can be used to identify the job to run. It might be
348used for statistical purposes and should identify the same time-class.
349
350Useful for short background jobs.
351
352=cut
353
354our @SLOT_QUEUE;
355our $SLOT_QUEUE;
356
357$SLOT_QUEUE->cancel if $SLOT_QUEUE;
358$SLOT_QUEUE = Coro::async {
359 $Coro::current->desc ("timeslot manager");
360
361 my $signal = new Coro::Signal;
362
363 while () {
364 next_job:
365 my $avail = cf::till_tick;
366 if ($avail > 0.01) {
367 for (0 .. $#SLOT_QUEUE) {
368 if ($SLOT_QUEUE[$_][0] < $avail) {
369 my $job = splice @SLOT_QUEUE, $_, 1, ();
370 $job->[2]->send;
371 Coro::cede;
372 goto next_job;
373 }
374 }
375 }
376
377 if (@SLOT_QUEUE) {
378 # we do not use wait_For_tick() as it returns immediately when tick is inactive
379 push @cf::WAIT_FOR_TICK, $signal;
380 $signal->wait;
381 } else {
382 Coro::schedule;
383 }
384 }
385};
386
387sub get_slot($;$$) {
388 my ($time, $pri, $name) = @_;
389
390 $time = $TICK * .6 if $time > $TICK * .6;
391 my $sig = new Coro::Signal;
392
393 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
394 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
395 $SLOT_QUEUE->ready;
396 $sig->wait;
397}
398
310=item cf::async { BLOCK } 399=item cf::async { BLOCK }
311 400
312Currently the same as Coro::async_pool, meaning you cannot use 401Currently the same as Coro::async_pool, meaning you cannot use
313C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 402C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
314thing you are allowed to do is call C<prio> on it. 403thing you are allowed to do is call C<prio> on it.
… …
317 406
318BEGIN { *async = \&Coro::async_pool } 407BEGIN { *async = \&Coro::async_pool }
319 408
320=item cf::sync_job { BLOCK } 409=item cf::sync_job { BLOCK }
321 410
322The design of crossfire+ requires that the main coro ($Coro::main) is 411The design of Crossfire TRT requires that the main coroutine ($Coro::main)
323always able to handle events or runnable, as crossfire+ is only partly 412is always able to handle events or runnable, as Crossfire TRT is only
324reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 413partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
414acceptable.
325 415
326If it must be done, put the blocking parts into C<sync_job>. This will run 416If it must be done, put the blocking parts into C<sync_job>. This will run
327the given BLOCK in another coroutine while waiting for the result. The 417the given BLOCK in another coroutine while waiting for the result. The
328server will be frozen during this time, so the block should either finish 418server will be frozen during this time, so the block should either finish
329fast or be very important. 419fast or be very important.
… …
337 my $time = Event::time; 427 my $time = Event::time;
338 428
339 # this is the main coro, too bad, we have to block 429 # this is the main coro, too bad, we have to block
340 # till the operation succeeds, freezing the server :/ 430 # till the operation succeeds, freezing the server :/
341 431
432 LOG llevError | logBacktrace, Carp::longmess "sync job";#d#
433
342 # TODO: use suspend/resume instead 434 # TODO: use suspend/resume instead
343 # (but this is cancel-safe) 435 # (but this is cancel-safe)
344 my $freeze_guard = freeze_mainloop; 436 my $freeze_guard = freeze_mainloop;
345 437
346 my $busy = 1; 438 my $busy = 1;
347 my @res; 439 my @res;
348 440
349 (async { 441 (async {
442 $Coro::current->desc ("sync job coro");
350 @res = eval { $job->() }; 443 @res = eval { $job->() };
351 warn $@ if $@; 444 warn $@ if $@;
352 undef $busy; 445 undef $busy;
353 })->prio (Coro::PRIO_MAX); 446 })->prio (Coro::PRIO_MAX);
354 447
… …
389 $EXT_CORO{$coro+0} = $coro; 482 $EXT_CORO{$coro+0} = $coro;
390 483
391 $coro 484 $coro
392} 485}
393 486
394sub write_runtime { 487=item fork_call { }, $args
395 my $runtime = "$LOCALDIR/runtime";
396 488
397 # first touch the runtime file to show we are still running: 489Executes the given code block with the given arguments in a seperate
398 # the fsync below can take a very very long time. 490process, returning the results. Everything must be serialisable with
491Coro::Storable. May, of course, block. Note that the executed sub may
492never block itself or use any form of Event handling.
399 493
400 IO::AIO::aio_utime $runtime, undef, undef; 494=cut
401 495
402 my $guard = cf::lock_acquire "write_runtime"; 496sub fork_call(&@) {
497 my ($cb, @args) = @_;
403 498
404 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 499 # we seemingly have to make a local copy of the whole thing,
405 or return; 500 # otherwise perl prematurely frees the stuff :/
501 # TODO: investigate and fix (likely this will be rather laborious)
406 502
407 my $value = $cf::RUNTIME + 90 + 10; 503 my @res = Coro::Util::fork_eval {
408 # 10 is the runtime save interval, for a monotonic clock 504 reset_signals;
409 # 60 allows for the watchdog to kill the server. 505 &$cb
506 }, @args;
410 507
411 (aio_write $fh, 0, (length $value), $value, 0) <= 0 508 wantarray ? @res : $res[-1]
412 and return; 509}
413 510
414 # always fsync - this file is important 511=item $value = cf::db_get $family => $key
415 aio_fsync $fh
416 and return;
417 512
418 # touch it again to show we are up-to-date 513Returns a single value from the environment database.
419 aio_utime $fh, undef, undef;
420 514
421 close $fh 515=item cf::db_put $family => $key => $value
422 or return;
423 516
424 aio_rename "$runtime~", $runtime 517Stores the given C<$value> in the family. It can currently store binary
425 and return; 518data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
426 519
427 warn "runtime file written.\n";#d# 520=item $db = cf::db_table "name"
428 521
522Create and/or open a new database table. The string must not be "db" and must be unique
523within each server.
524
525=cut
526
527sub db_table($) {
528 my ($name) = @_;
529 my $db = BDB::db_create $DB_ENV;
530
531 eval {
532 $db->set_flags (BDB::CHKSUM);
533
534 utf8::encode $name;
535 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
536 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
537 cf::cleanup "db_open(db): $!" if $!;
538 };
539 cf::cleanup "db_open(db): $@" if $@;
540
541 $db
542}
543
544our $DB;
545
546sub db_init {
547 cf::sync_job {
548 $DB ||= db_table "db";
549 };
550}
551
552sub db_get($$) {
553 my $key = "$_[0]/$_[1]";
554
555 cf::sync_job {
556 BDB::db_get $DB, undef, $key, my $data;
557
558 $! ? ()
559 : $data
429 1 560 }
561}
562
563sub db_put($$$) {
564 BDB::dbreq_pri 4;
565 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
566}
567
568=item cf::cache $id => [$paths...], $processversion => $process
569
570Generic caching function that returns the value of the resource $id,
571caching and regenerating as required.
572
573This function can block.
574
575=cut
576
577sub cache {
578 my ($id, $src, $processversion, $process) = @_;
579
580 my $meta =
581 join "\x00",
582 $processversion,
583 map {
584 aio_stat $_
585 and Carp::croak "$_: $!";
586
587 ($_, (stat _)[7,9])
588 } @$src;
589
590 my $dbmeta = db_get cache => "$id/meta";
591 if ($dbmeta ne $meta) {
592 # changed, we may need to process
593
594 my @data;
595 my $md5;
596
597 for (0 .. $#$src) {
598 0 <= aio_load $src->[$_], $data[$_]
599 or Carp::croak "$src->[$_]: $!";
600 }
601
602 # if processing is expensive, check
603 # checksum first
604 if (1) {
605 $md5 =
606 join "\x00",
607 $processversion,
608 map {
609 cf::cede_to_tick;
610 ($src->[$_], Digest::MD5::md5_hex $data[$_])
611 } 0.. $#$src;
612
613
614 my $dbmd5 = db_get cache => "$id/md5";
615 if ($dbmd5 eq $md5) {
616 db_put cache => "$id/meta", $meta;
617
618 return db_get cache => "$id/data";
619 }
620 }
621
622 my $t1 = Time::HiRes::time;
623 my $data = $process->(\@data);
624 my $t2 = Time::HiRes::time;
625
626 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
627
628 db_put cache => "$id/data", $data;
629 db_put cache => "$id/md5" , $md5;
630 db_put cache => "$id/meta", $meta;
631
632 return $data;
633 }
634
635 db_get cache => "$id/data"
430} 636}
431 637
432=item cf::datalog type => key => value, ... 638=item cf::datalog type => key => value, ...
433 639
434Log a datalog packet of the given type with the given key-value pairs. 640Log a datalog packet of the given type with the given key-value pairs.
… …
452attach callbacks/event handlers (a collection of which is called an "attachment") 658attach callbacks/event handlers (a collection of which is called an "attachment")
453to it. All such attachable objects support the following methods. 659to it. All such attachable objects support the following methods.
454 660
455In the following description, CLASS can be any of C<global>, C<object> 661In the following description, CLASS can be any of C<global>, C<object>
456C<player>, C<client> or C<map> (i.e. the attachable objects in 662C<player>, C<client> or C<map> (i.e. the attachable objects in
457crossfire+). 663Crossfire TRT).
458 664
459=over 4 665=over 4
460 666
461=item $attachable->attach ($attachment, key => $value...) 667=item $attachable->attach ($attachment, key => $value...)
462 668
… …
664 _attach $registry, $klass, @attach; 870 _attach $registry, $klass, @attach;
665 } 871 }
666 872
667 $obj->{$name} = \%arg; 873 $obj->{$name} = \%arg;
668 } else { 874 } else {
669 warn "object uses attachment '$name' that is not available, postponing.\n"; 875 warn "object uses attachment '$name' which is not available, postponing.\n";
670 } 876 }
671 877
672 $obj->{_attachment}{$name} = undef; 878 $obj->{_attachment}{$name} = undef;
673} 879}
674 880
… …
714 "; 920 ";
715 die if $@; 921 die if $@;
716} 922}
717 923
718our $override; 924our $override;
719our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 925our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
720 926
721sub override { 927sub override {
722 $override = 1; 928 $override = 1;
723 @invoke_results = (); 929 @INVOKE_RESULTS = (@_);
724} 930}
725 931
726sub do_invoke { 932sub do_invoke {
727 my $event = shift; 933 my $event = shift;
728 my $callbacks = shift; 934 my $callbacks = shift;
729 935
730 @invoke_results = (); 936 @INVOKE_RESULTS = ();
731 937
732 local $override; 938 local $override;
733 939
734 for (@$callbacks) { 940 for (@$callbacks) {
735 eval { &{$_->[1]} }; 941 eval { &{$_->[1]} };
… …
752 958
753Generate an object-specific event with the given arguments. 959Generate an object-specific event with the given arguments.
754 960
755This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 961This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
756removed in future versions), and there is no public API to access override 962removed in future versions), and there is no public API to access override
757results (if you must, access C<@cf::invoke_results> directly). 963results (if you must, access C<@cf::INVOKE_RESULTS> directly).
758 964
759=back 965=back
760 966
761=cut 967=cut
762 968
763############################################################################# 969#############################################################################
764# object support 970# object support
971#
972
973sub _can_merge {
974 my ($ob1, $ob2) = @_;
975
976 local $Storable::canonical = 1;
977 my $fob1 = Storable::freeze $ob1;
978 my $fob2 = Storable::freeze $ob2;
979
980 $fob1 eq $fob2
981}
765 982
766sub reattach { 983sub reattach {
767 # basically do the same as instantiate, without calling instantiate 984 # basically do the same as instantiate, without calling instantiate
768 my ($obj) = @_; 985 my ($obj) = @_;
769 986
… …
816sub object_freezer_save { 1033sub object_freezer_save {
817 my ($filename, $rdata, $objs) = @_; 1034 my ($filename, $rdata, $objs) = @_;
818 1035
819 sync_job { 1036 sync_job {
820 if (length $$rdata) { 1037 if (length $$rdata) {
1038 utf8::decode (my $decname = $filename);
821 warn sprintf "saving %s (%d,%d)\n", 1039 warn sprintf "saving %s (%d,%d)\n",
822 $filename, length $$rdata, scalar @$objs; 1040 $decname, length $$rdata, scalar @$objs;
823 1041
824 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1042 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
825 chmod SAVE_MODE, $fh; 1043 chmod SAVE_MODE, $fh;
826 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1044 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
827 aio_fsync $fh if $cf::USE_FSYNC; 1045 aio_fsync $fh if $cf::USE_FSYNC;
… …
846 } 1064 }
847 } else { 1065 } else {
848 aio_unlink $filename; 1066 aio_unlink $filename;
849 aio_unlink "$filename.pst"; 1067 aio_unlink "$filename.pst";
850 } 1068 }
851 } 1069 };
852} 1070}
853 1071
854sub object_freezer_as_string { 1072sub object_freezer_as_string {
855 my ($rdata, $objs) = @_; 1073 my ($rdata, $objs) = @_;
856 1074
… …
868 or return; 1086 or return;
869 1087
870 unless (aio_stat "$filename.pst") { 1088 unless (aio_stat "$filename.pst") {
871 (aio_load "$filename.pst", $av) >= 0 1089 (aio_load "$filename.pst", $av) >= 0
872 or return; 1090 or return;
1091
873 $av = eval { (Storable::thaw $av)->{objs} }; 1092 $av = eval { (Storable::thaw $av)->{objs} };
874 } 1093 }
875 1094
1095 utf8::decode (my $decname = $filename);
876 warn sprintf "loading %s (%d)\n", 1096 warn sprintf "loading %s (%d,%d)\n",
877 $filename, length $data, scalar @{$av || []};#d# 1097 $decname, length $data, scalar @{$av || []};
1098
878 return ($data, $av); 1099 ($data, $av)
879} 1100}
1101
1102=head2 COMMAND CALLBACKS
1103
1104=over 4
1105
1106=cut
880 1107
881############################################################################# 1108#############################################################################
882# command handling &c 1109# command handling &c
883 1110
884=item cf::register_command $name => \&callback($ob,$args); 1111=item cf::register_command $name => \&callback($ob,$args);
… …
897 push @{ $COMMAND{$name} }, [$caller, $cb]; 1124 push @{ $COMMAND{$name} }, [$caller, $cb];
898} 1125}
899 1126
900=item cf::register_extcmd $name => \&callback($pl,$packet); 1127=item cf::register_extcmd $name => \&callback($pl,$packet);
901 1128
902Register a callbackf ro execution when the client sends an extcmd packet. 1129Register a callback for execution when the client sends an (synchronous)
1130extcmd packet. Ext commands will be processed in the order they are
1131received by the server, like other user commands. The first argument is
1132the logged-in player. Ext commands can only be processed after a player
1133has logged in successfully.
903 1134
904If the callback returns something, it is sent back as if reply was being 1135If the callback returns something, it is sent back as if reply was being
905called. 1136called.
906 1137
1138=item cf::register_exticmd $name => \&callback($ns,$packet);
1139
1140Register a callback for execution when the client sends an (asynchronous)
1141exticmd packet. Exti commands are processed by the server as soon as they
1142are received, i.e. out of order w.r.t. other commands. The first argument
1143is a client socket. Exti commands can be received anytime, even before
1144log-in.
1145
1146If the callback returns something, it is sent back as if reply was being
1147called.
1148
907=cut 1149=cut
908 1150
909sub register_extcmd { 1151sub register_extcmd {
910 my ($name, $cb) = @_; 1152 my ($name, $cb) = @_;
911 1153
912 $EXTCMD{$name} = $cb; 1154 $EXTCMD{$name} = $cb;
1155}
1156
1157sub register_exticmd {
1158 my ($name, $cb) = @_;
1159
1160 $EXTICMD{$name} = $cb;
913} 1161}
914 1162
915cf::player->attach ( 1163cf::player->attach (
916 on_command => sub { 1164 on_command => sub {
917 my ($pl, $name, $params) = @_; 1165 my ($pl, $name, $params) = @_;
… …
926 cf::override; 1174 cf::override;
927 }, 1175 },
928 on_extcmd => sub { 1176 on_extcmd => sub {
929 my ($pl, $buf) = @_; 1177 my ($pl, $buf) = @_;
930 1178
931 my $msg = eval { from_json $buf }; 1179 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
932 1180
933 if (ref $msg) { 1181 if (ref $msg) {
1182 my ($type, $reply, @payload) =
1183 "ARRAY" eq ref $msg
1184 ? @$msg
1185 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1186
1187 my @reply;
1188
934 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1189 if (my $cb = $EXTCMD{$type}) {
935 if (my %reply = $cb->($pl, $msg)) { 1190 @reply = $cb->($pl, @payload);
936 $pl->ext_reply ($msg->{msgid}, %reply);
937 }
938 } 1191 }
1192
1193 $pl->ext_reply ($reply, @reply)
1194 if $reply;
1195
939 } else { 1196 } else {
940 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1197 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
941 } 1198 }
942 1199
943 cf::override; 1200 cf::override;
944 }, 1201 },
945); 1202);
946 1203
947sub load_extension {
948 my ($path) = @_;
949
950 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
951 my $base = $1;
952 my $pkg = $1;
953 $pkg =~ s/[^[:word:]]/_/g;
954 $pkg = "ext::$pkg";
955
956 warn "... loading '$path' into '$pkg'\n";
957
958 open my $fh, "<:utf8", $path
959 or die "$path: $!";
960
961 my $source =
962 "package $pkg; use strict; use utf8;\n"
963 . "#line 1 \"$path\"\n{\n"
964 . (do { local $/; <$fh> })
965 . "\n};\n1";
966
967 unless (eval $source) {
968 my $msg = $@ ? "$path: $@\n"
969 : "extension disabled.\n";
970 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
971 warn $@;
972 warn "mandatory extension failed to load, exiting.\n";
973 exit 1;
974 }
975 die $@;
976 }
977
978 push @EXTS, $pkg;
979}
980
981sub load_extensions { 1204sub load_extensions {
1205 cf::sync_job {
1206 my %todo;
1207
982 for my $ext (<$LIBDIR/*.ext>) { 1208 for my $path (<$LIBDIR/*.ext>) {
983 next unless -r $ext; 1209 next unless -r $path;
984 eval { 1210
985 load_extension $ext; 1211 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1212 my $base = $1;
1213 my $pkg = $1;
1214 $pkg =~ s/[^[:word:]]/_/g;
1215 $pkg = "ext::$pkg";
1216
1217 open my $fh, "<:utf8", $path
1218 or die "$path: $!";
1219
1220 my $source = do { local $/; <$fh> };
1221
1222 my %ext = (
1223 path => $path,
1224 base => $base,
1225 pkg => $pkg,
1226 );
1227
1228 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1229 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1230
1231 $ext{source} =
1232 "package $pkg; use strict; use utf8;\n"
1233 . "#line 1 \"$path\"\n{\n"
1234 . $source
1235 . "\n};\n1";
1236
1237 $todo{$base} = \%ext;
1238 }
1239
1240 my %done;
1241 while (%todo) {
1242 my $progress;
1243
1244 while (my ($k, $v) = each %todo) {
1245 for (split /,\s*/, $v->{meta}{depends}) {
1246 goto skip
1247 unless exists $done{$_};
1248 }
1249
1250 warn "... loading '$k' into '$v->{pkg}'\n";
1251
1252 unless (eval $v->{source}) {
1253 my $msg = $@ ? "$v->{path}: $@\n"
1254 : "$v->{base}: extension inactive.\n";
1255
1256 if (exists $v->{meta}{mandatory}) {
1257 warn $msg;
1258 warn "mandatory extension failed to load, exiting.\n";
1259 exit 1;
1260 }
1261
1262 warn $msg;
1263 }
1264
1265 $done{$k} = delete $todo{$k};
1266 push @EXTS, $v->{pkg};
1267 $progress = 1;
986 1 1268 }
987 } or warn "$ext not loaded: $@"; 1269
1270 skip:
1271 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1272 unless $progress;
1273 }
988 } 1274 };
989} 1275}
990 1276
991############################################################################# 1277#############################################################################
992 1278
1279=back
1280
993=head2 CORE EXTENSIONS 1281=head2 CORE EXTENSIONS
994 1282
995Functions and methods that extend core crossfire objects. 1283Functions and methods that extend core crossfire objects.
996 1284
997=cut 1285=cut
… …
1001use Coro::AIO; 1289use Coro::AIO;
1002 1290
1003=head3 cf::player 1291=head3 cf::player
1004 1292
1005=over 4 1293=over 4
1294
1295=item cf::player::num_playing
1296
1297Returns the official number of playing players, as per the Crossfire metaserver rules.
1298
1299=cut
1300
1301sub num_playing {
1302 scalar grep
1303 $_->ob->map
1304 && !$_->hidden
1305 && !$_->ob->flag (cf::FLAG_WIZ),
1306 cf::player::list
1307}
1006 1308
1007=item cf::player::find $login 1309=item cf::player::find $login
1008 1310
1009Returns the given player object, loading it if necessary (might block). 1311Returns the given player object, loading it if necessary (might block).
1010 1312
… …
1046 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1348 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1047 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1349 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1048 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1350 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1049 aio_unlink +(playerdir $login) . "/$login.pl"; 1351 aio_unlink +(playerdir $login) . "/$login.pl";
1050 1352
1051 my $pl = load_pl path $login 1353 my $f = new_from_file cf::object::thawer path $login
1052 or return; 1354 or return;
1355
1356 my $pl = cf::player::load_pl $f
1357 or return;
1358 local $cf::PLAYER_LOADING{$login} = $pl;
1359 $f->resolve_delayed_derefs;
1053 $cf::PLAYER{$login} = $pl 1360 $cf::PLAYER{$login} = $pl
1054 } 1361 }
1055 } 1362 }
1056} 1363}
1057 1364
… …
1067 1374
1068 aio_mkdir playerdir $pl, 0770; 1375 aio_mkdir playerdir $pl, 0770;
1069 $pl->{last_save} = $cf::RUNTIME; 1376 $pl->{last_save} = $cf::RUNTIME;
1070 1377
1071 $pl->save_pl ($path); 1378 $pl->save_pl ($path);
1072 Coro::cede; 1379 cf::cede_to_tick;
1073} 1380}
1074 1381
1075sub new($) { 1382sub new($) {
1076 my ($login) = @_; 1383 my ($login) = @_;
1077 1384
… …
1081 $self->{deny_save} = 1; 1388 $self->{deny_save} = 1;
1082 1389
1083 $cf::PLAYER{$login} = $self; 1390 $cf::PLAYER{$login} = $self;
1084 1391
1085 $self 1392 $self
1393}
1394
1395=item $player->send_msg ($channel, $msg, $color, [extra...])
1396
1397=cut
1398
1399sub send_msg {
1400 my $ns = shift->ns
1401 or return;
1402 $ns->send_msg (@_);
1086} 1403}
1087 1404
1088=item $pl->quit_character 1405=item $pl->quit_character
1089 1406
1090Nukes the player without looking back. If logged in, the connection will 1407Nukes the player without looking back. If logged in, the connection will
… …
1145 or return []; 1462 or return [];
1146 1463
1147 my @logins; 1464 my @logins;
1148 1465
1149 for my $login (@$dirs) { 1466 for my $login (@$dirs) {
1467 my $path = path $login;
1468
1469 # a .pst is a dead give-away for a valid player
1470 unless (-e "$path.pst") {
1150 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1471 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1151 aio_read $fh, 0, 512, my $buf, 0 or next; 1472 aio_read $fh, 0, 512, my $buf, 0 or next;
1152 $buf !~ /^password -------------$/m or next; # official not-valid tag 1473 $buf !~ /^password -------------$/m or next; # official not-valid tag
1474 }
1153 1475
1154 utf8::decode $login; 1476 utf8::decode $login;
1155 push @logins, $login; 1477 push @logins, $login;
1156 } 1478 }
1157 1479
… …
1184 } 1506 }
1185 1507
1186 \@paths 1508 \@paths
1187} 1509}
1188 1510
1511=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1512
1513Expand crossfire pod fragments into protocol xml.
1514
1515=cut
1516
1517sub expand_cfpod {
1518 ((my $self), (local $_)) = @_;
1519
1520 # escape & and <
1521 s/&/&amp;/g;
1522 s/(?<![BIUGHT])</&lt;/g;
1523
1524 # this is buggy, it needs to properly take care of nested <'s
1525
1526 1 while
1527 # replace B<>, I<>, U<> etc.
1528 s/B<([^\>]*)>/<b>$1<\/b>/
1529 || s/I<([^\>]*)>/<i>$1<\/i>/
1530 || s/U<([^\>]*)>/<u>$1<\/u>/
1531 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1532 # replace G<male|female> tags
1533 || s{G<([^>|]*)\|([^>]*)>}{
1534 $self->gender ? $2 : $1
1535 }ge
1536 # replace H<hint text>
1537 || s{H<([^\>]*)>}
1538 {
1539 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1540 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1541 "")
1542 [$self->{hintmode}]
1543 }ge;
1544
1545 # create single paragraphs (very hackish)
1546 s/(?<=\S)\n(?=\w)/ /g;
1547
1548 # compress some whitespace
1549 s/\s+\n/\n/g; # ws line-ends
1550 s/\n\n+/\n/g; # double lines
1551 s/^\n+//; # beginning lines
1552 s/\n+$//; # ending lines
1553
1554 $_
1555}
1556
1557sub hintmode {
1558 $_[0]{hintmode} = $_[1] if @_ > 1;
1559 $_[0]{hintmode}
1560}
1561
1189=item $player->ext_reply ($msgid, %msg) 1562=item $player->ext_reply ($msgid, @msg)
1190 1563
1191Sends an ext reply to the player. 1564Sends an ext reply to the player.
1192 1565
1193=cut 1566=cut
1194 1567
1195sub ext_reply($$%) { 1568sub ext_reply($$@) {
1196 my ($self, $id, %msg) = @_; 1569 my ($self, $id, @msg) = @_;
1197 1570
1198 $msg{msgid} = $id; 1571 $self->ns->ext_reply ($id, @msg)
1199
1200 $self->send ("ext " . cf::to_json \%msg);
1201} 1572}
1202 1573
1203=item $player->ext_event ($type, %msg) 1574=item $player->ext_msg ($type, @msg)
1204 1575
1205Sends an ext event to the client. 1576Sends an ext event to the client.
1206 1577
1207=cut 1578=cut
1208 1579
1209sub ext_event($$%) { 1580sub ext_msg($$@) {
1210 my ($self, $type, %msg) = @_; 1581 my ($self, $type, @msg) = @_;
1211 1582
1212 $self->ns->ext_event ($type, %msg); 1583 $self->ns->ext_msg ($type, @msg);
1213} 1584}
1214 1585
1215=head3 cf::region 1586=head3 cf::region
1216 1587
1217=over 4 1588=over 4
… …
1220 1591
1221package cf::region; 1592package cf::region;
1222 1593
1223=item cf::region::find_by_path $path 1594=item cf::region::find_by_path $path
1224 1595
1225Tries to decuce the probable region for a map knowing only its path. 1596Tries to decuce the likely region for a map knowing only its path.
1226 1597
1227=cut 1598=cut
1228 1599
1229sub find_by_path($) { 1600sub find_by_path($) {
1230 my ($path) = @_; 1601 my ($path) = @_;
1231 1602
1232 my ($match, $specificity); 1603 my ($match, $specificity);
1233 1604
1234 for my $region (list) { 1605 for my $region (list) {
1235 if ($region->match && $path =~ $region->match) { 1606 if ($region->{match} && $path =~ $region->{match}) {
1236 ($match, $specificity) = ($region, $region->specificity) 1607 ($match, $specificity) = ($region, $region->specificity)
1237 if $region->specificity > $specificity; 1608 if $region->specificity > $specificity;
1238 } 1609 }
1239 } 1610 }
1240 1611
… …
1304 my ($self, $merge) = @_; 1675 my ($self, $merge) = @_;
1305 1676
1306 # we have to keep some variables in memory intact 1677 # we have to keep some variables in memory intact
1307 local $self->{path}; 1678 local $self->{path};
1308 local $self->{load_path}; 1679 local $self->{load_path};
1309 local $self->{deny_save};
1310 local $self->{deny_reset};
1311 1680
1312 $self->SUPER::thawer_merge ($merge); 1681 $self->SUPER::thawer_merge ($merge);
1313} 1682}
1314 1683
1315sub normalise { 1684sub normalise {
… …
1362 $self->init; # pass $1 etc. 1731 $self->init; # pass $1 etc.
1363 return $self; 1732 return $self;
1364 } 1733 }
1365 } 1734 }
1366 1735
1367 Carp::carp "unable to resolve path '$path' (base '$base')."; 1736 Carp::cluck "unable to resolve path '$path' (base '$base').";
1368 () 1737 ()
1369} 1738}
1370 1739
1371sub init { 1740sub init {
1372 my ($self) = @_; 1741 my ($self) = @_;
… …
1415 1784
1416 $_->change_map_light ($change) 1785 $_->change_map_light ($change)
1417 for grep $_->outdoor, values %cf::MAP; 1786 for grep $_->outdoor, values %cf::MAP;
1418} 1787}
1419 1788
1789sub decay_objects {
1790 my ($self) = @_;
1791
1792 return if $self->{deny_reset};
1793
1794 $self->do_decay_objects;
1795}
1796
1420sub unlink_save { 1797sub unlink_save {
1421 my ($self) = @_; 1798 my ($self) = @_;
1422 1799
1423 utf8::encode (my $save = $self->save_path); 1800 utf8::encode (my $save = $self->save_path);
1424 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1801 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1427 1804
1428sub load_header_from($) { 1805sub load_header_from($) {
1429 my ($self, $path) = @_; 1806 my ($self, $path) = @_;
1430 1807
1431 utf8::encode $path; 1808 utf8::encode $path;
1432 #aio_open $path, O_RDONLY, 0 1809 my $f = new_from_file cf::object::thawer $path
1433 # or return;
1434
1435 $self->_load_header ($path)
1436 or return; 1810 or return;
1811
1812 $self->_load_header ($f)
1813 or return;
1814
1815 local $MAP_LOADING{$self->{path}} = $self;
1816 $f->resolve_delayed_derefs;
1437 1817
1438 $self->{load_path} = $path; 1818 $self->{load_path} = $path;
1439 1819
1440 1 1820 1
1441} 1821}
… …
1480 $self->load_header_orig 1860 $self->load_header_orig
1481 or return; 1861 or return;
1482 $self->prepare_orig; 1862 $self->prepare_orig;
1483 } 1863 }
1484 1864
1865 $self->{deny_reset} = 1
1866 if $self->no_reset;
1867
1485 $self->default_region (cf::region::find_by_path $self->{path}) 1868 $self->default_region (cf::region::find_by_path $self->{path})
1486 unless $self->default_region; 1869 unless $self->default_region;
1487 1870
1488 1 1871 1
1489} 1872}
… …
1492sub find { 1875sub find {
1493 my ($path, $origin) = @_; 1876 my ($path, $origin) = @_;
1494 1877
1495 $path = normalise $path, $origin && $origin->path; 1878 $path = normalise $path, $origin && $origin->path;
1496 1879
1880 cf::lock_wait "map_data:$path";#d#remove
1497 cf::lock_wait "map_find:$path"; 1881 cf::lock_wait "map_find:$path";
1498 1882
1499 $cf::MAP{$path} || do { 1883 $cf::MAP{$path} || do {
1500 my $guard = cf::lock_acquire "map_find:$path"; 1884 my $guard1 = cf::lock_acquire "map_find:$path";
1885 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1886
1501 my $map = new_from_path cf::map $path 1887 my $map = new_from_path cf::map $path
1502 or return; 1888 or return;
1503 1889
1504 $map->{last_save} = $cf::RUNTIME; 1890 $map->{last_save} = $cf::RUNTIME;
1505 1891
1506 $map->load_header 1892 $map->load_header
1507 or return; 1893 or return;
1508 1894
1509 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1895 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1510 # doing this can freeze the server in a sync job, obviously 1896 # doing this can freeze the server in a sync job, obviously
1511 #$cf::WAIT_FOR_TICK->wait; 1897 #$cf::WAIT_FOR_TICK->wait;
1898 undef $guard1;
1899 undef $guard2;
1512 $map->reset; 1900 $map->reset;
1513 undef $guard;
1514 return find $path; 1901 return find $path;
1515 } 1902 }
1516 1903
1517 $cf::MAP{$path} = $map 1904 $cf::MAP{$path} = $map
1518 } 1905 }
… …
1527 local $self->{deny_reset} = 1; # loading can take a long time 1914 local $self->{deny_reset} = 1; # loading can take a long time
1528 1915
1529 my $path = $self->{path}; 1916 my $path = $self->{path};
1530 1917
1531 { 1918 {
1532 my $guard = cf::lock_acquire "map_load:$path"; 1919 my $guard = cf::lock_acquire "map_data:$path";
1533 1920
1921 return unless $self->valid;
1534 return if $self->in_memory != cf::MAP_SWAPPED; 1922 return unless $self->in_memory == cf::MAP_SWAPPED;
1535 1923
1536 $self->in_memory (cf::MAP_LOADING); 1924 $self->in_memory (cf::MAP_LOADING);
1537 1925
1538 $self->alloc; 1926 $self->alloc;
1539 1927
1540 $self->pre_load; 1928 $self->pre_load;
1541 Coro::cede; 1929 cf::cede_to_tick;
1542 1930
1931 my $f = new_from_file cf::object::thawer $self->{load_path};
1932 $f->skip_block;
1543 $self->_load_objects ($self->{load_path}, 1) 1933 $self->_load_objects ($f)
1544 or return; 1934 or return;
1545 1935
1546 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1936 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1547 if delete $self->{load_original}; 1937 if delete $self->{load_original};
1548 1938
1549 if (my $uniq = $self->uniq_path) { 1939 if (my $uniq = $self->uniq_path) {
1550 utf8::encode $uniq; 1940 utf8::encode $uniq;
1551 if (aio_open $uniq, O_RDONLY, 0) { 1941 unless (aio_stat $uniq) {
1942 if (my $f = new_from_file cf::object::thawer $uniq) {
1552 $self->clear_unique_items; 1943 $self->clear_unique_items;
1553 $self->_load_objects ($uniq, 0); 1944 $self->_load_objects ($f);
1945 $f->resolve_delayed_derefs;
1946 }
1554 } 1947 }
1555 } 1948 }
1556 1949
1557 Coro::cede; 1950 $f->resolve_delayed_derefs;
1951
1952 cf::cede_to_tick;
1558 # now do the right thing for maps 1953 # now do the right thing for maps
1559 $self->link_multipart_objects; 1954 $self->link_multipart_objects;
1560 $self->difficulty ($self->estimate_difficulty) 1955 $self->difficulty ($self->estimate_difficulty)
1561 unless $self->difficulty; 1956 unless $self->difficulty;
1562 Coro::cede; 1957 cf::cede_to_tick;
1563 1958
1564 unless ($self->{deny_activate}) { 1959 unless ($self->{deny_activate}) {
1565 $self->decay_objects; 1960 $self->decay_objects;
1566 $self->fix_auto_apply; 1961 $self->fix_auto_apply;
1567 $self->update_buttons; 1962 $self->update_buttons;
1568 Coro::cede; 1963 cf::cede_to_tick;
1569 $self->set_darkness_map; 1964 $self->set_darkness_map;
1570 Coro::cede; 1965 cf::cede_to_tick;
1571 $self->activate; 1966 $self->activate;
1572 } 1967 }
1968
1969 $self->{last_save} = $cf::RUNTIME;
1970 $self->last_access ($cf::RUNTIME);
1573 1971
1574 $self->in_memory (cf::MAP_IN_MEMORY); 1972 $self->in_memory (cf::MAP_IN_MEMORY);
1575 } 1973 }
1576 1974
1577 $self->post_load; 1975 $self->post_load;
… …
1581 my ($self, $ob) = @_; 1979 my ($self, $ob) = @_;
1582 1980
1583 return find "~" . $ob->name . "/" . $self->{path} 1981 return find "~" . $ob->name . "/" . $self->{path}
1584 if $self->per_player; 1982 if $self->per_player;
1585 1983
1984# return find "?party/" . $ob->name . "/" . $self->{path}
1985# if $self->per_party;
1986
1586 $self 1987 $self
1587} 1988}
1588 1989
1589# find and load all maps in the 3x3 area around a map 1990# find and load all maps in the 3x3 area around a map
1590sub load_diag { 1991sub load_neighbours {
1591 my ($map) = @_; 1992 my ($map) = @_;
1592 1993
1593 my @diag; # diagonal neighbours 1994 my @neigh; # diagonal neighbours
1594 1995
1595 for (0 .. 3) { 1996 for (0 .. 3) {
1596 my $neigh = $map->tile_path ($_) 1997 my $neigh = $map->tile_path ($_)
1597 or next; 1998 or next;
1598 $neigh = find $neigh, $map 1999 $neigh = find $neigh, $map
1599 or next; 2000 or next;
1600 $neigh->load; 2001 $neigh->load;
1601 2002
2003 push @neigh,
1602 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2004 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1603 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2005 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1604 } 2006 }
1605 2007
1606 for (@diag) { 2008 for (grep defined $_->[0], @neigh) {
2009 my ($path, $origin) = @$_;
1607 my $neigh = find @$_ 2010 my $neigh = find $path, $origin
1608 or next; 2011 or next;
1609 $neigh->load; 2012 $neigh->load;
1610 } 2013 }
1611} 2014}
1612 2015
… …
1617} 2020}
1618 2021
1619sub do_load_sync { 2022sub do_load_sync {
1620 my ($map) = @_; 2023 my ($map) = @_;
1621 2024
2025 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2026 if $Coro::current == $Coro::main;
2027
1622 cf::sync_job { $map->load }; 2028 cf::sync_job { $map->load };
1623} 2029}
1624 2030
1625our %MAP_PREFETCH; 2031our %MAP_PREFETCH;
1626our $MAP_PREFETCHER = undef; 2032our $MAP_PREFETCHER = undef;
1627 2033
1628sub find_async { 2034sub find_async {
1629 my ($path, $origin) = @_; 2035 my ($path, $origin, $load) = @_;
1630 2036
1631 $path = normalise $path, $origin && $origin->{path}; 2037 $path = normalise $path, $origin && $origin->{path};
1632 2038
1633 if (my $map = $cf::MAP{$path}) { 2039 if (my $map = $cf::MAP{$path}) {
1634 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2040 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1635 } 2041 }
1636 2042
1637 undef $MAP_PREFETCH{$path}; 2043 $MAP_PREFETCH{$path} |= $load;
2044
1638 $MAP_PREFETCHER ||= cf::async { 2045 $MAP_PREFETCHER ||= cf::async {
2046 $Coro::current->{desc} = "map prefetcher";
2047
1639 while (%MAP_PREFETCH) { 2048 while (%MAP_PREFETCH) {
1640 for my $path (keys %MAP_PREFETCH) { 2049 while (my ($k, $v) = each %MAP_PREFETCH) {
1641 my $map = find $path 2050 if (my $map = find $k) {
1642 or next;
1643 $map->load; 2051 $map->load if $v;
2052 }
1644 2053
1645 delete $MAP_PREFETCH{$path}; 2054 delete $MAP_PREFETCH{$k};
1646 } 2055 }
1647 } 2056 }
1648 undef $MAP_PREFETCHER; 2057 undef $MAP_PREFETCHER;
1649 }; 2058 };
1650 $MAP_PREFETCHER->prio (6); 2059 $MAP_PREFETCHER->prio (6);
… …
1653} 2062}
1654 2063
1655sub save { 2064sub save {
1656 my ($self) = @_; 2065 my ($self) = @_;
1657 2066
1658 my $lock = cf::lock_acquire "map_data:" . $self->path; 2067 my $lock = cf::lock_acquire "map_data:$self->{path}";
1659 2068
1660 $self->{last_save} = $cf::RUNTIME; 2069 $self->{last_save} = $cf::RUNTIME;
1661 2070
1662 return unless $self->dirty; 2071 return unless $self->dirty;
1663 2072
… …
1669 return if $self->{deny_save}; 2078 return if $self->{deny_save};
1670 2079
1671 local $self->{last_access} = $self->last_access;#d# 2080 local $self->{last_access} = $self->last_access;#d#
1672 2081
1673 cf::async { 2082 cf::async {
2083 $Coro::current->{desc} = "map player save";
1674 $_->contr->save for $self->players; 2084 $_->contr->save for $self->players;
1675 }; 2085 };
1676 2086
1677 if ($uniq) { 2087 if ($uniq) {
1678 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2088 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
1686 my ($self) = @_; 2096 my ($self) = @_;
1687 2097
1688 # save first because save cedes 2098 # save first because save cedes
1689 $self->save; 2099 $self->save;
1690 2100
1691 my $lock = cf::lock_acquire "map_data:" . $self->path; 2101 my $lock = cf::lock_acquire "map_data:$self->{path}";
1692 2102
1693 return if $self->players; 2103 return if $self->players;
1694 return if $self->in_memory != cf::MAP_IN_MEMORY; 2104 return if $self->in_memory != cf::MAP_IN_MEMORY;
1695 return if $self->{deny_save}; 2105 return if $self->{deny_save};
1696 2106
2107 $self->in_memory (cf::MAP_SWAPPED);
2108
2109 $self->deactivate;
2110 $_->clear_links_to ($self) for values %cf::MAP;
1697 $self->clear; 2111 $self->clear;
1698 $self->in_memory (cf::MAP_SWAPPED);
1699} 2112}
1700 2113
1701sub reset_at { 2114sub reset_at {
1702 my ($self) = @_; 2115 my ($self) = @_;
1703 2116
1704 # TODO: safety, remove and allow resettable per-player maps 2117 # TODO: safety, remove and allow resettable per-player maps
1705 return 1e99 if $self->isa ("ext::map_per_player");#d#
1706 return 1e99 if $self->{deny_reset}; 2118 return 1e99 if $self->{deny_reset};
1707 2119
1708 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2120 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1709 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2121 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1710 2122
… …
1721 my ($self) = @_; 2133 my ($self) = @_;
1722 2134
1723 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2135 my $lock = cf::lock_acquire "map_data:$self->{path}";
1724 2136
1725 return if $self->players; 2137 return if $self->players;
1726 return if $self->isa ("ext::map_per_player");#d#
1727 2138
1728 warn "resetting map ", $self->path;#d# 2139 warn "resetting map ", $self->path;
1729 2140
1730 $self->in_memory (cf::MAP_SWAPPED); 2141 $self->in_memory (cf::MAP_SWAPPED);
1731 2142
1732 # need to save uniques path 2143 # need to save uniques path
1733 unless ($self->{deny_save}) { 2144 unless ($self->{deny_save}) {
… …
1737 if $uniq; 2148 if $uniq;
1738 } 2149 }
1739 2150
1740 delete $cf::MAP{$self->path}; 2151 delete $cf::MAP{$self->path};
1741 2152
2153 $self->deactivate;
2154 $_->clear_links_to ($self) for values %cf::MAP;
1742 $self->clear; 2155 $self->clear;
1743
1744 $_->clear_links_to ($self) for values %cf::MAP;
1745 2156
1746 $self->unlink_save; 2157 $self->unlink_save;
1747 $self->destroy; 2158 $self->destroy;
1748} 2159}
1749 2160
1750my $nuke_counter = "aaaa"; 2161my $nuke_counter = "aaaa";
1751 2162
1752sub nuke { 2163sub nuke {
1753 my ($self) = @_; 2164 my ($self) = @_;
1754 2165
2166 {
2167 my $lock = cf::lock_acquire "map_data:$self->{path}";
2168
1755 delete $cf::MAP{$self->path}; 2169 delete $cf::MAP{$self->path};
1756 2170
1757 $self->unlink_save; 2171 $self->unlink_save;
1758 2172
1759 bless $self, "cf::map"; 2173 bless $self, "cf::map";
1760 delete $self->{deny_reset}; 2174 delete $self->{deny_reset};
1761 $self->{deny_save} = 1; 2175 $self->{deny_save} = 1;
1762 $self->reset_timeout (1); 2176 $self->reset_timeout (1);
1763 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2177 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1764 2178
1765 $cf::MAP{$self->path} = $self; 2179 $cf::MAP{$self->path} = $self;
2180 }
1766 2181
1767 $self->reset; # polite request, might not happen 2182 $self->reset; # polite request, might not happen
2183}
2184
2185=item $maps = cf::map::tmp_maps
2186
2187Returns an arrayref with all map paths of currently instantiated and saved
2188maps. May block.
2189
2190=cut
2191
2192sub tmp_maps() {
2193 [
2194 map {
2195 utf8::decode $_;
2196 /\.map$/
2197 ? normalise $_
2198 : ()
2199 } @{ aio_readdir $TMPDIR or [] }
2200 ]
2201}
2202
2203=item $maps = cf::map::random_maps
2204
2205Returns an arrayref with all map paths of currently instantiated and saved
2206random maps. May block.
2207
2208=cut
2209
2210sub random_maps() {
2211 [
2212 map {
2213 utf8::decode $_;
2214 /\.map$/
2215 ? normalise "?random/$_"
2216 : ()
2217 } @{ aio_readdir $RANDOMDIR or [] }
2218 ]
1768} 2219}
1769 2220
1770=item cf::map::unique_maps 2221=item cf::map::unique_maps
1771 2222
1772Returns an arrayref of paths of all shared maps that have 2223Returns an arrayref of paths of all shared maps that have
1773instantiated unique items. May block. 2224instantiated unique items. May block.
1774 2225
1775=cut 2226=cut
1776 2227
1777sub unique_maps() { 2228sub unique_maps() {
1778 my $files = aio_readdir $UNIQUEDIR 2229 [
1779 or return; 2230 map {
1780
1781 my @paths;
1782
1783 for (@$files) {
1784 utf8::decode $_; 2231 utf8::decode $_;
1785 next if /\.pst$/; 2232 /\.map$/
1786 next unless /^$PATH_SEP/o; 2233 ? normalise $_
1787 2234 : ()
1788 push @paths, cf::map::normalise $_; 2235 } @{ aio_readdir $UNIQUEDIR or [] }
1789 } 2236 ]
1790
1791 \@paths
1792} 2237}
1793 2238
1794package cf; 2239package cf;
1795 2240
1796=back 2241=back
… …
1814 map { $_, inv_recursive_ $_->inv } @_ 2259 map { $_, inv_recursive_ $_->inv } @_
1815} 2260}
1816 2261
1817sub inv_recursive { 2262sub inv_recursive {
1818 inv_recursive_ inv $_[0] 2263 inv_recursive_ inv $_[0]
2264}
2265
2266=item $ref = $ob->ref
2267
2268creates and returns a persistent reference to an objetc that can be stored as a string.
2269
2270=item $ob = cf::object::deref ($refstring)
2271
2272returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2273even if the object actually exists. May block.
2274
2275=cut
2276
2277sub deref {
2278 my ($ref) = @_;
2279
2280 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2281 my ($uuid, $name) = ($1, $2);
2282 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2283 or return;
2284 $pl->ob->uuid eq $uuid
2285 or return;
2286
2287 $pl->ob
2288 } else {
2289 warn "$ref: cannot resolve object reference\n";
2290 undef
2291 }
1819} 2292}
1820 2293
1821package cf; 2294package cf;
1822 2295
1823=back 2296=back
… …
1842 2315
1843 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2316 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1844 2317
1845 if ($self->{record_replies}) { 2318 if ($self->{record_replies}) {
1846 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2319 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2320
1847 } else { 2321 } else {
2322 my $pl = $self->contr;
2323
2324 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2325 my $dialog = $pl->{npc_dialog};
2326 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2327
2328 } else {
1848 $msg = $npc->name . " says: $msg" if $npc; 2329 $msg = $npc->name . " says: $msg" if $npc;
1849 $self->message ($msg, $flags); 2330 $self->message ($msg, $flags);
2331 }
1850 } 2332 }
2333}
2334
2335=item $object->send_msg ($channel, $msg, $color, [extra...])
2336
2337=cut
2338
2339sub cf::object::send_msg {
2340 my $pl = shift->contr
2341 or return;
2342 $pl->send_msg (@_);
1851} 2343}
1852 2344
1853=item $player_object->may ("access") 2345=item $player_object->may ("access")
1854 2346
1855Returns wether the given player is authorized to access resource "access" 2347Returns wether the given player is authorized to access resource "access"
… …
1934 # use -1 or undef as default coordinates, not 0, 0 2426 # use -1 or undef as default coordinates, not 0, 0
1935 ($x, $y) = ($map->enter_x, $map->enter_y) 2427 ($x, $y) = ($map->enter_x, $map->enter_y)
1936 if $x <=0 && $y <= 0; 2428 if $x <=0 && $y <= 0;
1937 2429
1938 $map->load; 2430 $map->load;
1939 $map->load_diag; 2431 $map->load_neighbours;
1940 2432
1941 return unless $self->contr->active; 2433 return unless $self->contr->active;
1942 $self->activate_recursive; 2434 $self->activate_recursive;
1943 2435
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2436 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1945 $self->enter_map ($map, $x, $y); 2437 $self->enter_map ($map, $x, $y);
1946} 2438}
1947 2439
1948=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2440=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1949 2441
1950Moves the player to the given map-path and coordinates by first freezing 2442Moves the player to the given map-path and coordinates by first freezing
1951her, loading and preparing them map, calling the provided $check callback 2443her, loading and preparing them map, calling the provided $check callback
1952that has to return the map if sucecssful, and then unfreezes the player on 2444that has to return the map if sucecssful, and then unfreezes the player on
1953the new (success) or old (failed) map position. 2445the new (success) or old (failed) map position. In either case, $done will
2446be called at the end of this process.
1954 2447
1955=cut 2448=cut
1956 2449
1957our $GOTOGEN; 2450our $GOTOGEN;
1958 2451
1959sub cf::object::player::goto { 2452sub cf::object::player::goto {
1960 my ($self, $path, $x, $y, $check) = @_; 2453 my ($self, $path, $x, $y, $check, $done) = @_;
1961 2454
1962 # do generation counting so two concurrent goto's will be executed in-order 2455 # do generation counting so two concurrent goto's will be executed in-order
1963 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2456 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1964 2457
1965 $self->enter_link; 2458 $self->enter_link;
1966 2459
1967 (async { 2460 (async {
2461 $Coro::current->{desc} = "player::goto $path $x $y";
2462
2463 # *tag paths override both path and x|y
2464 if ($path =~ /^\*(.*)$/) {
2465 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2466 my $ob = $obs[rand @obs];
2467
2468 # see if we actually can go there
2469 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2470 $ob = $obs[rand @obs];
2471 } else {
2472 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2473 }
2474 # else put us there anyways for now #d#
2475
2476 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2477 } else {
2478 ($path, $x, $y) = (undef, undef, undef);
2479 }
2480 }
2481
1968 my $map = eval { 2482 my $map = eval {
1969 my $map = cf::map::find $path; 2483 my $map = defined $path ? cf::map::find $path : undef;
1970 2484
1971 if ($map) { 2485 if ($map) {
1972 $map = $map->customise_for ($self); 2486 $map = $map->customise_for ($self);
1973 $map = $check->($map) if $check && $map; 2487 $map = $check->($map) if $check && $map;
1974 } else { 2488 } else {
1975 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2489 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
1976 } 2490 }
1977 2491
1978 $map 2492 $map
1979 }; 2493 };
1980 2494
… …
1985 2499
1986 if ($gen == $self->{_goto_generation}) { 2500 if ($gen == $self->{_goto_generation}) {
1987 delete $self->{_goto_generation}; 2501 delete $self->{_goto_generation};
1988 $self->leave_link ($map, $x, $y); 2502 $self->leave_link ($map, $x, $y);
1989 } 2503 }
2504
2505 $done->() if $done;
1990 })->prio (1); 2506 })->prio (1);
1991} 2507}
1992 2508
1993=item $player_object->enter_exit ($exit_object) 2509=item $player_object->enter_exit ($exit_object)
1994 2510
… …
2063 my $hp = $exit->stats->hp; 2579 my $hp = $exit->stats->hp;
2064 my $sp = $exit->stats->sp; 2580 my $sp = $exit->stats->sp;
2065 2581
2066 $self->enter_link; 2582 $self->enter_link;
2067 2583
2584 # if exit is damned, update players death & WoR home-position
2585 $self->contr->savebed ($slaying, $hp, $sp)
2586 if $exit->flag (FLAG_DAMNED);
2587
2068 (async { 2588 (async {
2589 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2590
2069 $self->deactivate_recursive; # just to be sure 2591 $self->deactivate_recursive; # just to be sure
2070 unless (eval { 2592 unless (eval {
2071 $self->goto ($slaying, $hp, $sp); 2593 $self->goto ($slaying, $hp, $sp);
2072 2594
2073 1; 2595 1;
… …
2099 2621
2100 utf8::encode $text; 2622 utf8::encode $text;
2101 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2623 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2102} 2624}
2103 2625
2626=item $client->send_msg ($channel, $msg, $color, [extra...])
2627
2628Send a drawinfo or msg packet to the client, formatting the msg for the
2629client if neccessary. C<$type> should be a string identifying the type of
2630the message, with C<log> being the default. If C<$color> is negative, suppress
2631the message unless the client supports the msg packet.
2632
2633=cut
2634
2635our %CHANNEL = (
2636 "c/identify" => {
2637 id => "infobox",
2638 title => "Identify",
2639 reply => undef,
2640 tooltip => "Items recently identified",
2641 },
2642 "c/examine" => {
2643 id => "infobox",
2644 title => "Examine",
2645 reply => undef,
2646 tooltip => "Signs and other items you examined",
2647 },
2648 "c/lookat" => {
2649 id => "infobox",
2650 title => "Look",
2651 reply => undef,
2652 tooltip => "What you saw there",
2653 },
2654);
2655
2656sub cf::client::send_msg {
2657 my ($self, $channel, $msg, $color, @extra) = @_;
2658
2659 $msg = $self->pl->expand_cfpod ($msg);
2660
2661 $color &= cf::NDI_CLIENT_MASK; # just in case...
2662
2663 # check predefined channels, for the benefit of C
2664 if ($CHANNEL{$channel}) {
2665 $channel = $CHANNEL{$channel};
2666
2667 $self->ext_msg (channel_info => $channel)
2668 if $self->can_msg;
2669
2670 $channel = $channel->{id};
2671
2672 } elsif (ref $channel) {
2673 # send meta info to client, if not yet sent
2674 unless (exists $self->{channel}{$channel->{id}}) {
2675 $self->{channel}{$channel->{id}} = $channel;
2676 $self->ext_msg (channel_info => $channel)
2677 if $self->can_msg;
2678 }
2679
2680 $channel = $channel->{id};
2681 }
2682
2683 return unless @extra || length $msg;
2684
2685 if ($self->can_msg) {
2686 # default colour, mask it out
2687 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2688 if $color & cf::NDI_DEF;
2689
2690 $self->send_packet ("msg " . $self->{json_coder}->encode (
2691 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2692 } else {
2693 if ($color >= 0) {
2694 # replace some tags by gcfclient-compatible ones
2695 for ($msg) {
2696 1 while
2697 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2698 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2699 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2700 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2701 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2702 }
2703
2704 $color &= cf::NDI_COLOR_MASK;
2705
2706 utf8::encode $msg;
2707
2708 if (0 && $msg =~ /\[/) {
2709 # COMMAND/INFO
2710 $self->send_packet ("drawextinfo $color 10 8 $msg")
2711 } else {
2712 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2713 $self->send_packet ("drawinfo $color $msg")
2714 }
2715 }
2716 }
2717}
2718
2104=item $client->ext_event ($type, %msg) 2719=item $client->ext_msg ($type, @msg)
2105 2720
2106Sends an exti event to the client. 2721Sends an ext event to the client.
2107 2722
2108=cut 2723=cut
2109 2724
2110sub cf::client::ext_event($$%) { 2725sub cf::client::ext_msg($$@) {
2111 my ($self, $type, %msg) = @_; 2726 my ($self, $type, @msg) = @_;
2112 2727
2728 if ($self->extcmd == 2) {
2729 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2730 } elsif ($self->extcmd == 1) { # TODO: remove
2113 $msg{msgtype} = "event_$type"; 2731 push @msg, msgtype => "event_$type";
2114 $self->send_packet ("ext " . cf::to_json \%msg); 2732 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2733 }
2734}
2735
2736=item $client->ext_reply ($msgid, @msg)
2737
2738Sends an ext reply to the client.
2739
2740=cut
2741
2742sub cf::client::ext_reply($$@) {
2743 my ($self, $id, @msg) = @_;
2744
2745 if ($self->extcmd == 2) {
2746 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2747 } elsif ($self->extcmd == 1) {
2748 #TODO: version 1, remove
2749 unshift @msg, msgtype => "reply", msgid => $id;
2750 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2751 }
2115} 2752}
2116 2753
2117=item $success = $client->query ($flags, "text", \&cb) 2754=item $success = $client->query ($flags, "text", \&cb)
2118 2755
2119Queues a query to the client, calling the given callback with 2756Queues a query to the client, calling the given callback with
2120the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2757the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2121C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2758C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2122 2759
2123Queries can fail, so check the return code. Or don't, as queries will become 2760Queries can fail, so check the return code. Or don't, as queries will
2124reliable at some point in the future. 2761become reliable at some point in the future.
2125 2762
2126=cut 2763=cut
2127 2764
2128sub cf::client::query { 2765sub cf::client::query {
2129 my ($self, $flags, $text, $cb) = @_; 2766 my ($self, $flags, $text, $cb) = @_;
… …
2137 utf8::encode $text; 2774 utf8::encode $text;
2138 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2775 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2139 2776
2140 $self->send_packet ($self->{query_queue}[0][0]) 2777 $self->send_packet ($self->{query_queue}[0][0])
2141 if @{ $self->{query_queue} } == 1; 2778 if @{ $self->{query_queue} } == 1;
2779
2780 1
2142} 2781}
2143 2782
2144cf::client->attach ( 2783cf::client->attach (
2784 on_connect => sub {
2785 my ($ns) = @_;
2786
2787 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2788 },
2145 on_reply => sub { 2789 on_reply => sub {
2146 my ($ns, $msg) = @_; 2790 my ($ns, $msg) = @_;
2147 2791
2148 # this weird shuffling is so that direct followup queries 2792 # this weird shuffling is so that direct followup queries
2149 # get handled first 2793 # get handled first
… …
2161 } else { 2805 } else {
2162 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2806 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2163 } 2807 }
2164 } 2808 }
2165 }, 2809 },
2810 on_exticmd => sub {
2811 my ($ns, $buf) = @_;
2812
2813 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2814
2815 if (ref $msg) {
2816 my ($type, $reply, @payload) =
2817 "ARRAY" eq ref $msg
2818 ? @$msg
2819 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2820
2821 my @reply;
2822
2823 if (my $cb = $EXTICMD{$type}) {
2824 @reply = $cb->($ns, @payload);
2825 }
2826
2827 $ns->ext_reply ($reply, @reply)
2828 if $reply;
2829
2830 } else {
2831 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2832 }
2833
2834 cf::override;
2835 },
2166); 2836);
2167 2837
2168=item $client->async (\&cb) 2838=item $client->async (\&cb)
2169 2839
2170Create a new coroutine, running the specified callback. The coroutine will 2840Create a new coroutine, running the specified callback. The coroutine will
… …
2211our $safe = new Safe "safe"; 2881our $safe = new Safe "safe";
2212our $safe_hole = new Safe::Hole; 2882our $safe_hole = new Safe::Hole;
2213 2883
2214$SIG{FPE} = 'IGNORE'; 2884$SIG{FPE} = 'IGNORE';
2215 2885
2216$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2886$safe->permit_only (Opcode::opset qw(
2887 :base_core :base_mem :base_orig :base_math
2888 grepstart grepwhile mapstart mapwhile
2889 sort time
2890));
2217 2891
2218# here we export the classes and methods available to script code 2892# here we export the classes and methods available to script code
2219 2893
2220=pod 2894=pod
2221 2895
2222The following functions and methods are available within a safe environment: 2896The following functions and methods are available within a safe environment:
2223 2897
2224 cf::object contr pay_amount pay_player map 2898 cf::object
2899 contr pay_amount pay_player map x y force_find force_add
2900 insert remove name archname title slaying race decrease_ob_nr
2901
2225 cf::object::player player 2902 cf::object::player
2226 cf::player peaceful 2903 player
2227 cf::map trigger 2904
2905 cf::player
2906 peaceful
2907
2908 cf::map
2909 trigger
2228 2910
2229=cut 2911=cut
2230 2912
2231for ( 2913for (
2232 ["cf::object" => qw(contr pay_amount pay_player map)], 2914 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2915 insert remove inv name archname title slaying race
2916 decrease_ob_nr)],
2233 ["cf::object::player" => qw(player)], 2917 ["cf::object::player" => qw(player)],
2234 ["cf::player" => qw(peaceful)], 2918 ["cf::player" => qw(peaceful)],
2235 ["cf::map" => qw(trigger)], 2919 ["cf::map" => qw(trigger)],
2236) { 2920) {
2237 no strict 'refs'; 2921 no strict 'refs';
… …
2308=back 2992=back
2309 2993
2310=cut 2994=cut
2311 2995
2312############################################################################# 2996#############################################################################
2313
2314=head2 EXTENSION DATABASE SUPPORT
2315
2316Crossfire maintains a very simple database for extension use. It can
2317currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2318convert to/from binary).
2319
2320The parameter C<$family> should best start with the name of the extension
2321using it, it should be unique.
2322
2323=over 4
2324
2325=item $value = cf::db_get $family => $key
2326
2327Returns a single value from the database.
2328
2329=item cf::db_put $family => $key => $value
2330
2331Stores the given C<$value> in the family.
2332
2333=cut
2334
2335our $DB;
2336
2337sub db_init {
2338 unless ($DB) {
2339 $DB = BDB::db_create $DB_ENV;
2340
2341 cf::sync_job {
2342 eval {
2343 $DB->set_flags (BDB::CHKSUM);
2344
2345 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2346 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2347 cf::cleanup "db_open(db): $!" if $!;
2348 };
2349 cf::cleanup "db_open(db): $@" if $@;
2350 };
2351 }
2352}
2353
2354sub db_get($$) {
2355 my $key = "$_[0]/$_[1]";
2356
2357 cf::sync_job {
2358 BDB::db_get $DB, undef, $key, my $data;
2359
2360 $! ? ()
2361 : $data
2362 }
2363}
2364
2365sub db_put($$$) {
2366 BDB::dbreq_pri 4;
2367 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2368}
2369
2370=item cf::cache $id => [$paths...], $processversion => $process
2371
2372Generic caching function that returns the value of the resource $id,
2373caching and regenerating as required.
2374
2375This function can block.
2376
2377=cut
2378
2379sub cache {
2380 my ($id, $src, $processversion, $process) = @_;
2381
2382 my $meta =
2383 join "\x00",
2384 $processversion,
2385 map {
2386 aio_stat $_
2387 and Carp::croak "$_: $!";
2388
2389 ($_, (stat _)[7,9])
2390 } @$src;
2391
2392 my $dbmeta = db_get cache => "$id/meta";
2393 if ($dbmeta ne $meta) {
2394 # changed, we may need to process
2395
2396 my @data;
2397 my $md5;
2398
2399 for (0 .. $#$src) {
2400 0 <= aio_load $src->[$_], $data[$_]
2401 or Carp::croak "$src->[$_]: $!";
2402 }
2403
2404 # if processing is expensive, check
2405 # checksum first
2406 if (1) {
2407 $md5 =
2408 join "\x00",
2409 $processversion,
2410 map {
2411 Coro::cede;
2412 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2413 } 0.. $#$src;
2414
2415
2416 my $dbmd5 = db_get cache => "$id/md5";
2417 if ($dbmd5 eq $md5) {
2418 db_put cache => "$id/meta", $meta;
2419
2420 return db_get cache => "$id/data";
2421 }
2422 }
2423
2424 my $t1 = Time::HiRes::time;
2425 my $data = $process->(\@data);
2426 my $t2 = Time::HiRes::time;
2427
2428 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2429
2430 db_put cache => "$id/data", $data;
2431 db_put cache => "$id/md5" , $md5;
2432 db_put cache => "$id/meta", $meta;
2433
2434 return $data;
2435 }
2436
2437 db_get cache => "$id/data"
2438}
2439
2440=item fork_call { }, $args
2441
2442Executes the given code block with the given arguments in a seperate
2443process, returning the results. Everything must be serialisable with
2444Coro::Storable. May, of course, block. Note that the executed sub may
2445never block itself or use any form of Event handling.
2446
2447=cut
2448
2449sub fork_call(&@) {
2450 my ($cb, @args) = @_;
2451
2452# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2453# or die "socketpair: $!";
2454 pipe my $fh1, my $fh2
2455 or die "pipe: $!";
2456
2457 if (my $pid = fork) {
2458 close $fh2;
2459
2460 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2461 $res = Coro::Storable::thaw $res;
2462
2463 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2464
2465 die $$res unless "ARRAY" eq ref $res;
2466
2467 return wantarray ? @$res : $res->[-1];
2468 } else {
2469 reset_signals;
2470 local $SIG{__WARN__};
2471 local $SIG{__DIE__};
2472 eval {
2473 close $fh1;
2474
2475 my @res = eval { $cb->(@args) };
2476 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2477 };
2478
2479 warn $@ if $@;
2480 _exit 0;
2481 }
2482}
2483
2484#############################################################################
2485# the server's init and main functions 2997# the server's init and main functions
2486 2998
2487sub load_facedata($) { 2999sub load_facedata($) {
2488 my ($path) = @_; 3000 my ($path) = @_;
3001
3002 # HACK to clear player env face cache, we need some signal framework
3003 # for this (global event?)
3004 %ext::player_env::MUSIC_FACE_CACHE = ();
3005
3006 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2489 3007
2490 warn "loading facedata from $path\n"; 3008 warn "loading facedata from $path\n";
2491 3009
2492 my $facedata; 3010 my $facedata;
2493 0 < aio_load $path, $facedata 3011 0 < aio_load $path, $facedata
… …
2496 $facedata = Coro::Storable::thaw $facedata; 3014 $facedata = Coro::Storable::thaw $facedata;
2497 3015
2498 $facedata->{version} == 2 3016 $facedata->{version} == 2
2499 or cf::cleanup "$path: version mismatch, cannot proceed."; 3017 or cf::cleanup "$path: version mismatch, cannot proceed.";
2500 3018
3019 # patch in the exptable
3020 $facedata->{resource}{"res/exp_table"} = {
3021 type => FT_RSRC,
3022 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
3023 };
3024 cf::cede_to_tick;
3025
2501 { 3026 {
2502 my $faces = $facedata->{faceinfo}; 3027 my $faces = $facedata->{faceinfo};
2503 3028
2504 while (my ($face, $info) = each %$faces) { 3029 while (my ($face, $info) = each %$faces) {
2505 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3030 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2506 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 3031 cf::face::set_visibility $idx, $info->{visibility};
3032 cf::face::set_magicmap $idx, $info->{magicmap};
2507 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3033 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2508 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3034 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2509 Coro::cede; 3035
3036 cf::cede_to_tick;
2510 } 3037 }
2511 3038
2512 while (my ($face, $info) = each %$faces) { 3039 while (my ($face, $info) = each %$faces) {
2513 next unless $info->{smooth}; 3040 next unless $info->{smooth};
2514 my $idx = cf::face::find $face 3041 my $idx = cf::face::find $face
2515 or next; 3042 or next;
2516 if (my $smooth = cf::face::find $info->{smooth}) { 3043 if (my $smooth = cf::face::find $info->{smooth}) {
3044 cf::face::set_smooth $idx, $smooth;
2517 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3045 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2518 } else { 3046 } else {
2519 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3047 warn "smooth face '$info->{smooth}' not found for face '$face'";
2520 } 3048 }
2521 Coro::cede; 3049
3050 cf::cede_to_tick;
2522 } 3051 }
2523 } 3052 }
2524 3053
2525 { 3054 {
2526 my $anims = $facedata->{animinfo}; 3055 my $anims = $facedata->{animinfo};
2527 3056
2528 while (my ($anim, $info) = each %$anims) { 3057 while (my ($anim, $info) = each %$anims) {
2529 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3058 cf::anim::set $anim, $info->{frames}, $info->{facings};
2530 Coro::cede; 3059 cf::cede_to_tick;
2531 } 3060 }
2532 3061
2533 cf::anim::invalidate_all; # d'oh 3062 cf::anim::invalidate_all; # d'oh
2534 } 3063 }
2535 3064
3065 {
3066 # TODO: for gcfclient pleasure, we should give resources
3067 # that gcfclient doesn't grok a >10000 face index.
3068 my $res = $facedata->{resource};
3069
3070 my $soundconf = delete $res->{"res/sound.conf"};
3071
3072 while (my ($name, $info) = each %$res) {
3073 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3074 my $data;
3075
3076 if ($info->{type} & 1) {
3077 # prepend meta info
3078
3079 my $meta = $enc->encode ({
3080 name => $name,
3081 %{ $info->{meta} || {} },
3082 });
3083
3084 $data = pack "(w/a*)*", $meta, $info->{data};
3085 } else {
3086 $data = $info->{data};
3087 }
3088
3089 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3090 cf::face::set_type $idx, $info->{type};
3091
3092 cf::cede_to_tick;
3093 }
3094
3095 if ($soundconf) {
3096 $soundconf = $enc->decode (delete $soundconf->{data});
3097
3098 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3099 my $sound = $soundconf->{compat}[$_]
3100 or next;
3101
3102 my $face = cf::face::find "sound/$sound->[1]";
3103 cf::sound::set $sound->[0] => $face;
3104 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3105 }
3106
3107 while (my ($k, $v) = each %{$soundconf->{event}}) {
3108 my $face = cf::face::find "sound/$v";
3109 cf::sound::set $k => $face;
3110 }
3111 }
3112 }
3113
2536 1 3114 1
2537} 3115}
2538 3116
3117register_exticmd fx_want => sub {
3118 my ($ns, $want) = @_;
3119
3120 while (my ($k, $v) = each %$want) {
3121 $ns->fx_want ($k, $v);
3122 }
3123};
3124
2539sub reload_regions { 3125sub reload_regions {
3126 # HACK to clear player env face cache, we need some signal framework
3127 # for this (global event?)
3128 %ext::player_env::MUSIC_FACE_CACHE = ();
3129
2540 load_resource_file "$MAPDIR/regions" 3130 load_resource_file "$MAPDIR/regions"
2541 or die "unable to load regions file\n"; 3131 or die "unable to load regions file\n";
3132
3133 for (cf::region::list) {
3134 $_->{match} = qr/$_->{match}/
3135 if exists $_->{match};
3136 }
2542} 3137}
2543 3138
2544sub reload_facedata { 3139sub reload_facedata {
2545 load_facedata "$DATADIR/facedata" 3140 load_facedata "$DATADIR/facedata"
2546 or die "unable to load facedata\n"; 3141 or die "unable to load facedata\n";
2547} 3142}
2548 3143
2549sub reload_archetypes { 3144sub reload_archetypes {
2550 load_resource_file "$DATADIR/archetypes" 3145 load_resource_file "$DATADIR/archetypes"
2551 or die "unable to load archetypes\n"; 3146 or die "unable to load archetypes\n";
3147 #d# NEED to laod twice to resolve forward references
3148 # this really needs to be done in an extra post-pass
3149 # (which needs to be synchronous, so solve it differently)
3150 load_resource_file "$DATADIR/archetypes"
3151 or die "unable to load archetypes\n";
2552} 3152}
2553 3153
2554sub reload_treasures { 3154sub reload_treasures {
2555 load_resource_file "$DATADIR/treasures" 3155 load_resource_file "$DATADIR/treasures"
2556 or die "unable to load treasurelists\n"; 3156 or die "unable to load treasurelists\n";
… …
2559sub reload_resources { 3159sub reload_resources {
2560 warn "reloading resource files...\n"; 3160 warn "reloading resource files...\n";
2561 3161
2562 reload_regions; 3162 reload_regions;
2563 reload_facedata; 3163 reload_facedata;
3164 #reload_archetypes;#d#
2564 reload_archetypes; 3165 reload_archetypes;
2565 reload_treasures; 3166 reload_treasures;
2566 3167
2567 warn "finished reloading resource files\n"; 3168 warn "finished reloading resource files\n";
2568} 3169}
2569 3170
2570sub init { 3171sub init {
2571 reload_resources; 3172 reload_resources;
2572} 3173}
2573 3174
2574sub cfg_load { 3175sub reload_config {
2575 open my $fh, "<:utf8", "$CONFDIR/config" 3176 open my $fh, "<:utf8", "$CONFDIR/config"
2576 or return; 3177 or return;
2577 3178
2578 local $/; 3179 local $/;
2579 *CFG = YAML::Syck::Load <$fh>; 3180 *CFG = YAML::Syck::Load <$fh>;
… …
2595sub main { 3196sub main {
2596 # we must not ever block the main coroutine 3197 # we must not ever block the main coroutine
2597 local $Coro::idle = sub { 3198 local $Coro::idle = sub {
2598 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3199 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
2599 (async { 3200 (async {
3201 $Coro::current->{desc} = "IDLE BUG HANDLER";
2600 Event::one_event; 3202 Event::one_event;
2601 })->prio (Coro::PRIO_MAX); 3203 })->prio (Coro::PRIO_MAX);
2602 }; 3204 };
2603 3205
2604 cfg_load; 3206 reload_config;
2605 db_init; 3207 db_init;
2606 load_extensions; 3208 load_extensions;
2607 3209
2608 $TICK_WATCHER->start; 3210 $TICK_WATCHER->start;
2609 Event::loop; 3211 Event::loop;
… …
2625 }, 3227 },
2626 ); 3228 );
2627 } 3229 }
2628} 3230}
2629 3231
3232sub write_runtime {
3233 my $runtime = "$LOCALDIR/runtime";
3234
3235 # first touch the runtime file to show we are still running:
3236 # the fsync below can take a very very long time.
3237
3238 IO::AIO::aio_utime $runtime, undef, undef;
3239
3240 my $guard = cf::lock_acquire "write_runtime";
3241
3242 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3243 or return;
3244
3245 my $value = $cf::RUNTIME + 90 + 10;
3246 # 10 is the runtime save interval, for a monotonic clock
3247 # 60 allows for the watchdog to kill the server.
3248
3249 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3250 and return;
3251
3252 # always fsync - this file is important
3253 aio_fsync $fh
3254 and return;
3255
3256 # touch it again to show we are up-to-date
3257 aio_utime $fh, undef, undef;
3258
3259 close $fh
3260 or return;
3261
3262 aio_rename "$runtime~", $runtime
3263 and return;
3264
3265 warn "runtime file written.\n";
3266
3267 1
3268}
3269
2630sub emergency_save() { 3270sub emergency_save() {
2631 my $freeze_guard = cf::freeze_mainloop; 3271 my $freeze_guard = cf::freeze_mainloop;
2632 3272
2633 warn "enter emergency perl save\n"; 3273 warn "enter emergency perl save\n";
2634 3274
… …
2709 %EXT_CORO = (); 3349 %EXT_CORO = ();
2710 3350
2711 warn "removing commands"; 3351 warn "removing commands";
2712 %COMMAND = (); 3352 %COMMAND = ();
2713 3353
2714 warn "removing ext commands"; 3354 warn "removing ext/exti commands";
2715 %EXTCMD = (); 3355 %EXTCMD = ();
3356 %EXTICMD = ();
2716 3357
2717 warn "unloading/nuking all extensions"; 3358 warn "unloading/nuking all extensions";
2718 for my $pkg (@EXTS) { 3359 for my $pkg (@EXTS) {
2719 warn "... unloading $pkg"; 3360 warn "... unloading $pkg";
2720 3361
… …
2763 warn "reloading cf.pm"; 3404 warn "reloading cf.pm";
2764 require cf; 3405 require cf;
2765 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3406 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2766 3407
2767 warn "loading config and database again"; 3408 warn "loading config and database again";
2768 cf::cfg_load; 3409 cf::reload_config;
2769 3410
2770 warn "loading extensions"; 3411 warn "loading extensions";
2771 cf::load_extensions; 3412 cf::load_extensions;
2772 3413
2773 warn "reattaching attachments to objects/players"; 3414 warn "reattaching attachments to objects/players";
… …
2809register_command "reload" => sub { 3450register_command "reload" => sub {
2810 my ($who, $arg) = @_; 3451 my ($who, $arg) = @_;
2811 3452
2812 if ($who->flag (FLAG_WIZ)) { 3453 if ($who->flag (FLAG_WIZ)) {
2813 $who->message ("reloading server."); 3454 $who->message ("reloading server.");
3455 async {
3456 $Coro::current->{desc} = "perl_reload";
2814 async { reload_perl }; 3457 reload_perl;
3458 };
2815 } 3459 }
2816}; 3460};
2817 3461
2818unshift @INC, $LIBDIR; 3462unshift @INC, $LIBDIR;
2819 3463
… …
2838 my $signal = new Coro::Signal; 3482 my $signal = new Coro::Signal;
2839 push @WAIT_FOR_TICK_BEGIN, $signal; 3483 push @WAIT_FOR_TICK_BEGIN, $signal;
2840 $signal->wait; 3484 $signal->wait;
2841} 3485}
2842 3486
2843 my $min = 1e6;#d#
2844 my $avg = 10;
2845$TICK_WATCHER = Event->timer ( 3487$TICK_WATCHER = Event->timer (
2846 reentrant => 0, 3488 reentrant => 0,
2847 parked => 1, 3489 parked => 1,
2848 prio => 0, 3490 prio => 0,
2849 at => $NEXT_TICK || $TICK, 3491 at => $NEXT_TICK || $TICK,
… …
2857 3499
2858 $NOW = $tick_start = Event::time; 3500 $NOW = $tick_start = Event::time;
2859 3501
2860 cf::server_tick; # one server iteration 3502 cf::server_tick; # one server iteration
2861 3503
2862 0 && sync_job {#d#
2863 for(1..10) {
2864 my $t = Event::time;
2865 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2866 or die;
2867
2868 $map->width (50);
2869 $map->height (50);
2870 $map->alloc;
2871 $map->_load_objects ("/tmp/x.map", 1);
2872 my $t = Event::time - $t;
2873
2874 #next unless $t < 0.0013;#d#
2875 if ($t < $min) {
2876 $min = $t;
2877 }
2878 $avg = $avg * 0.99 + $t * 0.01;
2879 }
2880 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2881 exit 0;
2882 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2883 };
2884
2885 $RUNTIME += $TICK; 3504 $RUNTIME += $TICK;
2886 $NEXT_TICK += $TICK; 3505 $NEXT_TICK += $TICK;
2887 3506
2888 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3507 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2889 $NEXT_RUNTIME_WRITE = $NOW + 10; 3508 $NEXT_RUNTIME_WRITE = $NOW + 10;
2890 Coro::async_pool { 3509 Coro::async_pool {
3510 $Coro::current->{desc} = "runtime saver";
2891 write_runtime 3511 write_runtime
2892 or warn "ERROR: unable to write runtime file: $!"; 3512 or warn "ERROR: unable to write runtime file: $!";
2893 }; 3513 };
2894 } 3514 }
2895 3515
2896# my $AFTER = Event::time;
2897# warn $AFTER - $NOW;#d#
2898
2899 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3516 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2900 $sig->send; 3517 $sig->send;
2901 } 3518 }
2902 while (my $sig = shift @WAIT_FOR_TICK) { 3519 while (my $sig = shift @WAIT_FOR_TICK) {
2903 $sig->send; 3520 $sig->send;
… …
2913 3530
2914 $LOAD = ($NOW - $tick_start) / $TICK; 3531 $LOAD = ($NOW - $tick_start) / $TICK;
2915 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3532 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2916 3533
2917 _post_tick; 3534 _post_tick;
2918
2919
2920 }, 3535 },
2921); 3536);
2922 3537
2923{ 3538{
3539 BDB::min_parallel 8;
2924 BDB::max_poll_time $TICK * 0.1; 3540 BDB::max_poll_time $TICK * 0.1;
2925 $BDB_POLL_WATCHER = Event->io ( 3541 $BDB_POLL_WATCHER = Event->io (
2926 reentrant => 0, 3542 reentrant => 0,
2927 fd => BDB::poll_fileno, 3543 fd => BDB::poll_fileno,
2928 poll => 'r', 3544 poll => 'r',
2929 prio => 0, 3545 prio => 0,
2930 data => WF_AUTOCANCEL, 3546 data => WF_AUTOCANCEL,
2931 cb => \&BDB::poll_cb, 3547 cb => \&BDB::poll_cb,
2932 ); 3548 );
2933 BDB::min_parallel 8;
2934 3549
2935 BDB::set_sync_prepare { 3550 BDB::set_sync_prepare {
2936 my $status; 3551 my $status;
2937 my $current = $Coro::current; 3552 my $current = $Coro::current;
2938 ( 3553 (
… …
2947 ) 3562 )
2948 }; 3563 };
2949 3564
2950 unless ($DB_ENV) { 3565 unless ($DB_ENV) {
2951 $DB_ENV = BDB::db_env_create; 3566 $DB_ENV = BDB::db_env_create;
3567 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3568 | BDB::LOG_AUTOREMOVE, 1);
3569 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3570 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
2952 3571
2953 cf::sync_job { 3572 cf::sync_job {
2954 eval { 3573 eval {
2955 BDB::db_env_open 3574 BDB::db_env_open
2956 $DB_ENV, 3575 $DB_ENV,
… …
2958 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3577 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2959 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3578 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2960 0666; 3579 0666;
2961 3580
2962 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3581 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2963
2964 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2965 $DB_ENV->set_lk_detect;
2966 }; 3582 };
2967 3583
2968 cf::cleanup "db_env_open(db): $@" if $@; 3584 cf::cleanup "db_env_open(db): $@" if $@;
2969 }; 3585 };
2970 } 3586 }
3587
3588 $BDB_DEADLOCK_WATCHER = Event->timer (
3589 after => 3,
3590 interval => 1,
3591 hard => 1,
3592 prio => 0,
3593 data => WF_AUTOCANCEL,
3594 cb => sub {
3595 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3596 },
3597 );
3598 $BDB_CHECKPOINT_WATCHER = Event->timer (
3599 after => 11,
3600 interval => 60,
3601 hard => 1,
3602 prio => 0,
3603 data => WF_AUTOCANCEL,
3604 cb => sub {
3605 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3606 },
3607 );
3608 $BDB_TRICKLE_WATCHER = Event->timer (
3609 after => 5,
3610 interval => 10,
3611 hard => 1,
3612 prio => 0,
3613 data => WF_AUTOCANCEL,
3614 cb => sub {
3615 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3616 },
3617 );
2971} 3618}
2972 3619
2973{ 3620{
2974 IO::AIO::min_parallel 8; 3621 IO::AIO::min_parallel 8;
2975 3622
… …
2978 $AIO_POLL_WATCHER = Event->io ( 3625 $AIO_POLL_WATCHER = Event->io (
2979 reentrant => 0, 3626 reentrant => 0,
2980 data => WF_AUTOCANCEL, 3627 data => WF_AUTOCANCEL,
2981 fd => IO::AIO::poll_fileno, 3628 fd => IO::AIO::poll_fileno,
2982 poll => 'r', 3629 poll => 'r',
2983 prio => 6, 3630 prio => 0,
2984 cb => \&IO::AIO::poll_cb, 3631 cb => \&IO::AIO::poll_cb,
2985 ); 3632 );
2986} 3633}
2987 3634
2988my $_log_backtrace; 3635my $_log_backtrace;
… …
2994 3641
2995 # limit the # of concurrent backtraces 3642 # limit the # of concurrent backtraces
2996 if ($_log_backtrace < 2) { 3643 if ($_log_backtrace < 2) {
2997 ++$_log_backtrace; 3644 ++$_log_backtrace;
2998 async { 3645 async {
3646 $Coro::current->{desc} = "abt $msg";
3647
2999 my @bt = fork_call { 3648 my @bt = fork_call {
3000 @addr = map { sprintf "%x", $_ } @addr; 3649 @addr = map { sprintf "%x", $_ } @addr;
3001 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3650 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3002 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3651 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3003 or die "addr2line: $!"; 3652 or die "addr2line: $!";

Diff Legend

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