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.266 by root, Fri May 18 01:01:02 2007 UTC vs.
Revision 1.351 by root, Sun Sep 2 00:57:38 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;
164 168
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 169These 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 170returns 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. 171per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168 172
173=item @cf::INVOKE_RESULTS
174
175This array contains the results of the last C<invoke ()> call. When
176C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
177that call.
178
169=back 179=back
170 180
171=cut 181=cut
172 182
173BEGIN { 183BEGIN {
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
188@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
189@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
190@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
191@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 201@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
202@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
192@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 203@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
193 204
194# we bless all objects into (empty) derived classes to force a method lookup 205# we bless all objects into (empty) derived classes to force a method lookup
195# within the Safe compartment. 206# within the Safe compartment.
196for my $pkg (qw( 207for my $pkg (qw(
197 cf::global cf::attachable 208 cf::global cf::attachable
205} 216}
206 217
207$Event::DIED = sub { 218$Event::DIED = sub {
208 warn "error in event callback: @_"; 219 warn "error in event callback: @_";
209}; 220};
221
222#############################################################################
210 223
211=head2 UTILITY FUNCTIONS 224=head2 UTILITY FUNCTIONS
212 225
213=over 4 226=over 4
214 227
233 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
234 $d 247 $d
235 } || "[unable to dump $_[0]: '$@']"; 248 } || "[unable to dump $_[0]: '$@']";
236} 249}
237 250
238use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
239
240=item $ref = cf::from_json $json 251=item $ref = cf::from_json $json
241 252
242Converts a JSON string into the corresponding perl data structure. 253Converts a JSON string into the corresponding perl data structure.
243 254
244=item $json = cf::to_json $ref 255=item $json = cf::to_json $ref
245 256
246Converts a perl data structure into its JSON representation. 257Converts a perl data structure into its JSON representation.
258
259=cut
260
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262
263sub to_json ($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) }
247 265
248=item cf::lock_wait $string 266=item cf::lock_wait $string
249 267
250Wait until the given lock is available. See cf::lock_acquire. 268Wait until the given lock is available. See cf::lock_acquire.
251 269
253 271
254Wait until the given lock is available and then acquires it and returns 272Wait 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, 273a Coro::guard object. If the guard object gets destroyed (goes out of scope,
256for example when the coroutine gets canceled), the lock is automatically 274for example when the coroutine gets canceled), the lock is automatically
257returned. 275returned.
276
277Locks are *not* recursive, locking from the same coro twice results in a
278deadlocked coro.
258 279
259Lock names should begin with a unique identifier (for example, cf::map::find 280Lock names should begin with a unique identifier (for example, cf::map::find
260uses map_find and cf::map::load uses map_load). 281uses map_find and cf::map::load uses map_load).
261 282
262=item $locked = cf::lock_active $string 283=item $locked = cf::lock_active $string
305 }; 326 };
306 $TICK_WATCHER->stop; 327 $TICK_WATCHER->stop;
307 $guard 328 $guard
308} 329}
309 330
331=item cf::get_slot $time[, $priority[, $name]]
332
333Allocate $time seconds of blocking CPU time at priority C<$priority>:
334This call blocks and returns only when you have at least C<$time> seconds
335of cpu time till the next tick. The slot is only valid till the next cede.
336
337The optional C<$name> can be used to identify the job to run. It might be
338used for statistical purposes and should identify the same time-class.
339
340Useful for short background jobs.
341
342=cut
343
344our @SLOT_QUEUE;
345our $SLOT_QUEUE;
346
347$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348$SLOT_QUEUE = Coro::async {
349 my $signal = new Coro::Signal;
350
351 while () {
352 next_job:
353 my $avail = cf::till_tick;
354 if ($avail > 0.01) {
355 for (0 .. $#SLOT_QUEUE) {
356 if ($SLOT_QUEUE[$_][0] < $avail) {
357 my $job = splice @SLOT_QUEUE, $_, 1, ();
358 $job->[2]->send;
359 Coro::cede;
360 goto next_job;
361 }
362 }
363 }
364
365 if (@SLOT_QUEUE) {
366 # we do not use wait_For_tick() as it returns immediately when tick is inactive
367 push @cf::WAIT_FOR_TICK, $signal;
368 $signal->wait;
369 } else {
370 Coro::schedule;
371 }
372 }
373};
374
375sub get_slot($;$$) {
376 my ($time, $pri, $name) = @_;
377
378 $time = $TICK * .6 if $time > $TICK * .6;
379 my $sig = new Coro::Signal;
380
381 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
382 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
383 $SLOT_QUEUE->ready;
384 $sig->wait;
385}
386
310=item cf::async { BLOCK } 387=item cf::async { BLOCK }
311 388
312Currently the same as Coro::async_pool, meaning you cannot use 389Currently the same as Coro::async_pool, meaning you cannot use
313C<on_destroy>, C<join> or other gimmicks on these coroutines. The only 390C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
314thing you are allowed to do is call C<prio> on it. 391thing you are allowed to do is call C<prio> on it.
317 394
318BEGIN { *async = \&Coro::async_pool } 395BEGIN { *async = \&Coro::async_pool }
319 396
320=item cf::sync_job { BLOCK } 397=item cf::sync_job { BLOCK }
321 398
322The design of crossfire+ requires that the main coro ($Coro::main) is 399The design of Crossfire TRT requires that the main coroutine ($Coro::main)
323always able to handle events or runnable, as crossfire+ is only partly 400is 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. 401partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable.
325 403
326If it must be done, put the blocking parts into C<sync_job>. This will run 404If 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 405the given BLOCK in another coroutine while waiting for the result. The
328server will be frozen during this time, so the block should either finish 406server will be frozen during this time, so the block should either finish
329fast or be very important. 407fast or be very important.
389 $EXT_CORO{$coro+0} = $coro; 467 $EXT_CORO{$coro+0} = $coro;
390 468
391 $coro 469 $coro
392} 470}
393 471
394sub write_runtime { 472=item fork_call { }, $args
395 my $runtime = "$LOCALDIR/runtime";
396 473
397 # first touch the runtime file to show we are still running: 474Executes the given code block with the given arguments in a seperate
398 # the fsync below can take a very very long time. 475process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling.
399 478
400 if (my $fh = aio_open $runtime, O_WRONLY, 0) { 479=cut
401 utime undef, undef, $fh;
402 }
403 480
404 my $guard = cf::lock_acquire "write_runtime"; 481sub fork_call(&@) {
482 my ($cb, @args) = @_;
405 483
406 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 484 # we seemingly have to make a local copy of the whole thing,
407 or return; 485 # otherwise perl prematurely frees the stuff :/
486 # TODO: investigate and fix (liekly this will be rather laborious)
408 487
409 my $value = $cf::RUNTIME + 90 + 10; 488 my @res = Coro::Util::fork_eval {
410 # 10 is the runtime save interval, for a monotonic clock 489 reset_signals;
411 # 60 allows for the watchdog to kill the server. 490 &$cb
491 }, @args;
412 492
413 (aio_write $fh, 0, (length $value), $value, 0) <= 0 493 wantarray ? @res : $res[-1]
414 and return; 494}
415 495
416 # always fsync - this file is important 496=item $value = cf::db_get $family => $key
417 aio_fsync $fh
418 and return;
419 497
420 # touch it again to show we are up-to-date 498Returns a single value from the environment database.
421 utime undef, undef, $fh;
422 499
423 close $fh 500=item cf::db_put $family => $key => $value
424 or return;
425 501
426 aio_rename "$runtime~", $runtime 502Stores the given C<$value> in the family. It can currently store binary
427 and return; 503data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
428 504
429 warn "runtime file written.\n";#d# 505=cut
430 506
507our $DB;
508
509sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job {
514 eval {
515 $DB->set_flags (BDB::CHKSUM);
516
517 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
518 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
519 cf::cleanup "db_open(db): $!" if $!;
520 };
521 cf::cleanup "db_open(db): $@" if $@;
522 };
431 1 523 }
524}
525
526sub db_get($$) {
527 my $key = "$_[0]/$_[1]";
528
529 cf::sync_job {
530 BDB::db_get $DB, undef, $key, my $data;
531
532 $! ? ()
533 : $data
534 }
535}
536
537sub db_put($$$) {
538 BDB::dbreq_pri 4;
539 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
540}
541
542=item cf::cache $id => [$paths...], $processversion => $process
543
544Generic caching function that returns the value of the resource $id,
545caching and regenerating as required.
546
547This function can block.
548
549=cut
550
551sub cache {
552 my ($id, $src, $processversion, $process) = @_;
553
554 my $meta =
555 join "\x00",
556 $processversion,
557 map {
558 aio_stat $_
559 and Carp::croak "$_: $!";
560
561 ($_, (stat _)[7,9])
562 } @$src;
563
564 my $dbmeta = db_get cache => "$id/meta";
565 if ($dbmeta ne $meta) {
566 # changed, we may need to process
567
568 my @data;
569 my $md5;
570
571 for (0 .. $#$src) {
572 0 <= aio_load $src->[$_], $data[$_]
573 or Carp::croak "$src->[$_]: $!";
574 }
575
576 # if processing is expensive, check
577 # checksum first
578 if (1) {
579 $md5 =
580 join "\x00",
581 $processversion,
582 map {
583 cf::cede_to_tick;
584 ($src->[$_], Digest::MD5::md5_hex $data[$_])
585 } 0.. $#$src;
586
587
588 my $dbmd5 = db_get cache => "$id/md5";
589 if ($dbmd5 eq $md5) {
590 db_put cache => "$id/meta", $meta;
591
592 return db_get cache => "$id/data";
593 }
594 }
595
596 my $t1 = Time::HiRes::time;
597 my $data = $process->(\@data);
598 my $t2 = Time::HiRes::time;
599
600 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
601
602 db_put cache => "$id/data", $data;
603 db_put cache => "$id/md5" , $md5;
604 db_put cache => "$id/meta", $meta;
605
606 return $data;
607 }
608
609 db_get cache => "$id/data"
432} 610}
433 611
434=item cf::datalog type => key => value, ... 612=item cf::datalog type => key => value, ...
435 613
436Log a datalog packet of the given type with the given key-value pairs. 614Log a datalog packet of the given type with the given key-value pairs.
454attach callbacks/event handlers (a collection of which is called an "attachment") 632attach callbacks/event handlers (a collection of which is called an "attachment")
455to it. All such attachable objects support the following methods. 633to it. All such attachable objects support the following methods.
456 634
457In the following description, CLASS can be any of C<global>, C<object> 635In the following description, CLASS can be any of C<global>, C<object>
458C<player>, C<client> or C<map> (i.e. the attachable objects in 636C<player>, C<client> or C<map> (i.e. the attachable objects in
459crossfire+). 637Crossfire TRT).
460 638
461=over 4 639=over 4
462 640
463=item $attachable->attach ($attachment, key => $value...) 641=item $attachable->attach ($attachment, key => $value...)
464 642
627 $registry = $CB_TYPE[$object_type] ||= []; 805 $registry = $CB_TYPE[$object_type] ||= [];
628 806
629 } elsif ($type eq "subtype") { 807 } elsif ($type eq "subtype") {
630 defined $object_type or Carp::croak "subtype specified without type"; 808 defined $object_type or Carp::croak "subtype specified without type";
631 my $object_subtype = shift @arg; 809 my $object_subtype = shift @arg;
632 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 810 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
633 811
634 } elsif ($type eq "package") { 812 } elsif ($type eq "package") {
635 my $pkg = shift @arg; 813 my $pkg = shift @arg;
636 814
637 while (my ($name, $id) = each %cb_id) { 815 while (my ($name, $id) = each %cb_id) {
666 _attach $registry, $klass, @attach; 844 _attach $registry, $klass, @attach;
667 } 845 }
668 846
669 $obj->{$name} = \%arg; 847 $obj->{$name} = \%arg;
670 } else { 848 } else {
671 warn "object uses attachment '$name' that is not available, postponing.\n"; 849 warn "object uses attachment '$name' which is not available, postponing.\n";
672 } 850 }
673 851
674 $obj->{_attachment}{$name} = undef; 852 $obj->{_attachment}{$name} = undef;
675} 853}
676 854
678 if (ref $_[0]) { 856 if (ref $_[0]) {
679 _object_attach @_; 857 _object_attach @_;
680 } else { 858 } else {
681 _attach shift->_attach_registry, @_; 859 _attach shift->_attach_registry, @_;
682 } 860 }
861 _recalc_want;
683}; 862};
684 863
685# all those should be optimised 864# all those should be optimised
686sub cf::attachable::detach { 865sub cf::attachable::detach {
687 my ($obj, $name) = @_; 866 my ($obj, $name) = @_;
690 delete $obj->{_attachment}{$name}; 869 delete $obj->{_attachment}{$name};
691 reattach ($obj); 870 reattach ($obj);
692 } else { 871 } else {
693 Carp::croak "cannot, currently, detach class attachments"; 872 Carp::croak "cannot, currently, detach class attachments";
694 } 873 }
874 _recalc_want;
695}; 875};
696 876
697sub cf::attachable::attached { 877sub cf::attachable::attached {
698 my ($obj, $name) = @_; 878 my ($obj, $name) = @_;
699 879
714 "; 894 ";
715 die if $@; 895 die if $@;
716} 896}
717 897
718our $override; 898our $override;
719our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 899our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
720 900
721sub override { 901sub override {
722 $override = 1; 902 $override = 1;
723 @invoke_results = (); 903 @INVOKE_RESULTS = (@_);
724} 904}
725 905
726sub do_invoke { 906sub do_invoke {
727 my $event = shift; 907 my $event = shift;
728 my $callbacks = shift; 908 my $callbacks = shift;
729 909
730 @invoke_results = (); 910 @INVOKE_RESULTS = ();
731 911
732 local $override; 912 local $override;
733 913
734 for (@$callbacks) { 914 for (@$callbacks) {
735 eval { &{$_->[1]} }; 915 eval { &{$_->[1]} };
752 932
753Generate an object-specific event with the given arguments. 933Generate an object-specific event with the given arguments.
754 934
755This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 935This 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 936removed in future versions), and there is no public API to access override
757results (if you must, access C<@cf::invoke_results> directly). 937results (if you must, access C<@cf::INVOKE_RESULTS> directly).
758 938
759=back 939=back
760 940
761=cut 941=cut
762 942
763############################################################################# 943#############################################################################
764# object support 944# object support
945#
946
947sub _can_merge {
948 my ($ob1, $ob2) = @_;
949
950 local $Storable::canonical = 1;
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953
954 $fob1 eq $fob2
955}
765 956
766sub reattach { 957sub reattach {
767 # basically do the same as instantiate, without calling instantiate 958 # basically do the same as instantiate, without calling instantiate
768 my ($obj) = @_; 959 my ($obj) = @_;
769 960
872 or return; 1063 or return;
873 $av = eval { (Storable::thaw $av)->{objs} }; 1064 $av = eval { (Storable::thaw $av)->{objs} };
874 } 1065 }
875 1066
876 warn sprintf "loading %s (%d)\n", 1067 warn sprintf "loading %s (%d)\n",
877 $filename, length $data, scalar @{$av || []};#d# 1068 $filename, length $data, scalar @{$av || []};
878 return ($data, $av); 1069 return ($data, $av);
879} 1070}
1071
1072=head2 COMMAND CALLBACKS
1073
1074=over 4
1075
1076=cut
880 1077
881############################################################################# 1078#############################################################################
882# command handling &c 1079# command handling &c
883 1080
884=item cf::register_command $name => \&callback($ob,$args); 1081=item cf::register_command $name => \&callback($ob,$args);
897 push @{ $COMMAND{$name} }, [$caller, $cb]; 1094 push @{ $COMMAND{$name} }, [$caller, $cb];
898} 1095}
899 1096
900=item cf::register_extcmd $name => \&callback($pl,$packet); 1097=item cf::register_extcmd $name => \&callback($pl,$packet);
901 1098
902Register a callbackf ro execution when the client sends an extcmd packet. 1099Register a callback for execution when the client sends an (synchronous)
1100extcmd packet. Ext commands will be processed in the order they are
1101received by the server, like other user commands. The first argument is
1102the logged-in player. Ext commands can only be processed after a player
1103has logged in successfully.
903 1104
904If the callback returns something, it is sent back as if reply was being 1105If the callback returns something, it is sent back as if reply was being
905called. 1106called.
906 1107
1108=item cf::register_exticmd $name => \&callback($ns,$packet);
1109
1110Register a callback for execution when the client sends an (asynchronous)
1111exticmd packet. Exti commands are processed by the server as soon as they
1112are received, i.e. out of order w.r.t. other commands. The first argument
1113is a client socket. Exti commands can be received anytime, even before
1114log-in.
1115
1116If the callback returns something, it is sent back as if reply was being
1117called.
1118
907=cut 1119=cut
908 1120
909sub register_extcmd { 1121sub register_extcmd {
910 my ($name, $cb) = @_; 1122 my ($name, $cb) = @_;
911 1123
912 $EXTCMD{$name} = $cb; 1124 $EXTCMD{$name} = $cb;
1125}
1126
1127sub register_exticmd {
1128 my ($name, $cb) = @_;
1129
1130 $EXTICMD{$name} = $cb;
913} 1131}
914 1132
915cf::player->attach ( 1133cf::player->attach (
916 on_command => sub { 1134 on_command => sub {
917 my ($pl, $name, $params) = @_; 1135 my ($pl, $name, $params) = @_;
926 cf::override; 1144 cf::override;
927 }, 1145 },
928 on_extcmd => sub { 1146 on_extcmd => sub {
929 my ($pl, $buf) = @_; 1147 my ($pl, $buf) = @_;
930 1148
931 my $msg = eval { from_json $buf }; 1149 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
932 1150
933 if (ref $msg) { 1151 if (ref $msg) {
1152 my ($type, $reply, @payload) =
1153 "ARRAY" eq ref $msg
1154 ? @$msg
1155 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1156
1157 my @reply;
1158
934 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1159 if (my $cb = $EXTCMD{$type}) {
935 if (my %reply = $cb->($pl, $msg)) { 1160 @reply = $cb->($pl, @payload);
936 $pl->ext_reply ($msg->{msgid}, %reply);
937 }
938 } 1161 }
1162
1163 $pl->ext_reply ($reply, @reply)
1164 if $reply;
1165
939 } else { 1166 } else {
940 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1167 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
941 } 1168 }
942 1169
943 cf::override; 1170 cf::override;
944 }, 1171 },
945); 1172);
946 1173
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 { 1174sub load_extensions {
1175 cf::sync_job {
1176 my %todo;
1177
982 for my $ext (<$LIBDIR/*.ext>) { 1178 for my $path (<$LIBDIR/*.ext>) {
983 next unless -r $ext; 1179 next unless -r $path;
984 eval { 1180
985 load_extension $ext; 1181 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1182 my $base = $1;
1183 my $pkg = $1;
1184 $pkg =~ s/[^[:word:]]/_/g;
1185 $pkg = "ext::$pkg";
1186
1187 open my $fh, "<:utf8", $path
1188 or die "$path: $!";
1189
1190 my $source = do { local $/; <$fh> };
1191
1192 my %ext = (
1193 path => $path,
1194 base => $base,
1195 pkg => $pkg,
1196 );
1197
1198 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1199 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1200
1201 $ext{source} =
1202 "package $pkg; use strict; use utf8;\n"
1203 . "#line 1 \"$path\"\n{\n"
1204 . $source
1205 . "\n};\n1";
1206
1207 $todo{$base} = \%ext;
1208 }
1209
1210 my %done;
1211 while (%todo) {
1212 my $progress;
1213
1214 while (my ($k, $v) = each %todo) {
1215 for (split /,\s*/, $v->{meta}{depends}) {
1216 goto skip
1217 unless exists $done{$_};
1218 }
1219
1220 warn "... loading '$k' into '$v->{pkg}'\n";
1221
1222 unless (eval $v->{source}) {
1223 my $msg = $@ ? "$v->{path}: $@\n"
1224 : "$v->{base}: extension inactive.\n";
1225
1226 if (exists $v->{meta}{mandatory}) {
1227 warn $msg;
1228 warn "mandatory extension failed to load, exiting.\n";
1229 exit 1;
1230 }
1231
1232 warn $msg;
1233 }
1234
1235 $done{$k} = delete $todo{$k};
1236 push @EXTS, $v->{pkg};
1237 $progress = 1;
986 1 1238 }
987 } or warn "$ext not loaded: $@"; 1239
1240 skip:
1241 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1242 unless $progress;
1243 }
988 } 1244 };
989} 1245}
990 1246
991############################################################################# 1247#############################################################################
1248
1249=back
992 1250
993=head2 CORE EXTENSIONS 1251=head2 CORE EXTENSIONS
994 1252
995Functions and methods that extend core crossfire objects. 1253Functions and methods that extend core crossfire objects.
996 1254
1067 1325
1068 aio_mkdir playerdir $pl, 0770; 1326 aio_mkdir playerdir $pl, 0770;
1069 $pl->{last_save} = $cf::RUNTIME; 1327 $pl->{last_save} = $cf::RUNTIME;
1070 1328
1071 $pl->save_pl ($path); 1329 $pl->save_pl ($path);
1072 Coro::cede; 1330 cf::cede_to_tick;
1073} 1331}
1074 1332
1075sub new($) { 1333sub new($) {
1076 my ($login) = @_; 1334 my ($login) = @_;
1077 1335
1081 $self->{deny_save} = 1; 1339 $self->{deny_save} = 1;
1082 1340
1083 $cf::PLAYER{$login} = $self; 1341 $cf::PLAYER{$login} = $self;
1084 1342
1085 $self 1343 $self
1344}
1345
1346=item $player->send_msg ($channel, $msg, $color, [extra...])
1347
1348=cut
1349
1350sub send_msg {
1351 my $ns = shift->ns
1352 or return;
1353 $ns->send_msg (@_);
1086} 1354}
1087 1355
1088=item $pl->quit_character 1356=item $pl->quit_character
1089 1357
1090Nukes the player without looking back. If logged in, the connection will 1358Nukes the player without looking back. If logged in, the connection will
1184 } 1452 }
1185 1453
1186 \@paths 1454 \@paths
1187} 1455}
1188 1456
1457=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1458
1459Expand crossfire pod fragments into protocol xml.
1460
1461=cut
1462
1463sub expand_cfpod {
1464 ((my $self), (local $_)) = @_;
1465
1466 # escape & and <
1467 s/&/&amp;/g;
1468 s/(?<![BIUGH])</&lt;/g;
1469
1470 # this is buggy, it needs to properly take care of nested <'s
1471
1472 1 while
1473 # replace B<>, I<>, U<> etc.
1474 s/B<([^\>]*)>/<b>$1<\/b>/
1475 || s/I<([^\>]*)>/<i>$1<\/i>/
1476 || s/U<([^\>]*)>/<u>$1<\/u>/
1477 # replace G<male|female> tags
1478 || s{G<([^>|]*)\|([^>]*)>}{
1479 $self->gender ? $2 : $1
1480 }ge
1481 # replace H<hint text>
1482 || s{H<([^\>]*)>}
1483 {
1484 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1485 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1486 "")
1487 [$self->{hintmode}]
1488 }ge;
1489
1490 # create single paragraphs (very hackish)
1491 s/(?<=\S)\n(?=\w)/ /g;
1492
1493 # compress some whitespace
1494 s/\s+\n/\n/g; # ws line-ends
1495 s/\n\n+/\n/g; # double lines
1496 s/^\n+//; # beginning lines
1497 s/\n+$//; # ending lines
1498
1499 $_
1500}
1501
1502sub hintmode {
1503 $_[0]{hintmode} = $_[1] if @_ > 1;
1504 $_[0]{hintmode}
1505}
1506
1189=item $player->ext_reply ($msgid, %msg) 1507=item $player->ext_reply ($msgid, @msg)
1190 1508
1191Sends an ext reply to the player. 1509Sends an ext reply to the player.
1192 1510
1193=cut 1511=cut
1194 1512
1195sub ext_reply($$%) { 1513sub ext_reply($$@) {
1196 my ($self, $id, %msg) = @_; 1514 my ($self, $id, @msg) = @_;
1197 1515
1198 $msg{msgid} = $id; 1516 $self->ns->ext_reply ($id, @msg)
1199
1200 $self->send ("ext " . cf::to_json \%msg);
1201} 1517}
1202 1518
1203=item $player->ext_event ($type, %msg) 1519=item $player->ext_msg ($type, @msg)
1204 1520
1205Sends an ext event to the client. 1521Sends an ext event to the client.
1206 1522
1207=cut 1523=cut
1208 1524
1209sub ext_event($$%) { 1525sub ext_msg($$@) {
1210 my ($self, $type, %msg) = @_; 1526 my ($self, $type, @msg) = @_;
1211 1527
1212 $self->ns->ext_event ($type, %msg); 1528 $self->ns->ext_msg ($type, @msg);
1213} 1529}
1214 1530
1215=head3 cf::region 1531=head3 cf::region
1216 1532
1217=over 4 1533=over 4
1220 1536
1221package cf::region; 1537package cf::region;
1222 1538
1223=item cf::region::find_by_path $path 1539=item cf::region::find_by_path $path
1224 1540
1225Tries to decuce the probable region for a map knowing only its path. 1541Tries to decuce the likely region for a map knowing only its path.
1226 1542
1227=cut 1543=cut
1228 1544
1229sub find_by_path($) { 1545sub find_by_path($) {
1230 my ($path) = @_; 1546 my ($path) = @_;
1231 1547
1232 my ($match, $specificity); 1548 my ($match, $specificity);
1233 1549
1234 for my $region (list) { 1550 for my $region (list) {
1235 if ($region->match && $path =~ $region->match) { 1551 if ($region->{match} && $path =~ $region->{match}) {
1236 ($match, $specificity) = ($region, $region->specificity) 1552 ($match, $specificity) = ($region, $region->specificity)
1237 if $region->specificity > $specificity; 1553 if $region->specificity > $specificity;
1238 } 1554 }
1239 } 1555 }
1240 1556
1304 my ($self, $merge) = @_; 1620 my ($self, $merge) = @_;
1305 1621
1306 # we have to keep some variables in memory intact 1622 # we have to keep some variables in memory intact
1307 local $self->{path}; 1623 local $self->{path};
1308 local $self->{load_path}; 1624 local $self->{load_path};
1309 local $self->{deny_save};
1310 local $self->{deny_reset};
1311 1625
1312 $self->SUPER::thawer_merge ($merge); 1626 $self->SUPER::thawer_merge ($merge);
1313} 1627}
1314 1628
1315sub normalise { 1629sub normalise {
1362 $self->init; # pass $1 etc. 1676 $self->init; # pass $1 etc.
1363 return $self; 1677 return $self;
1364 } 1678 }
1365 } 1679 }
1366 1680
1367 Carp::carp "unable to resolve path '$path' (base '$base')."; 1681 Carp::cluck "unable to resolve path '$path' (base '$base').";
1368 () 1682 ()
1369} 1683}
1370 1684
1371sub init { 1685sub init {
1372 my ($self) = @_; 1686 my ($self) = @_;
1413sub change_all_map_light { 1727sub change_all_map_light {
1414 my ($change) = @_; 1728 my ($change) = @_;
1415 1729
1416 $_->change_map_light ($change) 1730 $_->change_map_light ($change)
1417 for grep $_->outdoor, values %cf::MAP; 1731 for grep $_->outdoor, values %cf::MAP;
1732}
1733
1734sub decay_objects {
1735 my ($self) = @_;
1736
1737 return if $self->{deny_reset};
1738
1739 $self->do_decay_objects;
1418} 1740}
1419 1741
1420sub unlink_save { 1742sub unlink_save {
1421 my ($self) = @_; 1743 my ($self) = @_;
1422 1744
1480 $self->load_header_orig 1802 $self->load_header_orig
1481 or return; 1803 or return;
1482 $self->prepare_orig; 1804 $self->prepare_orig;
1483 } 1805 }
1484 1806
1807 $self->{deny_reset} = 1
1808 if $self->no_reset;
1809
1485 $self->default_region (cf::region::find_by_path $self->{path}) 1810 $self->default_region (cf::region::find_by_path $self->{path})
1486 unless $self->default_region; 1811 unless $self->default_region;
1487 1812
1488 1 1813 1
1489} 1814}
1504 $map->{last_save} = $cf::RUNTIME; 1829 $map->{last_save} = $cf::RUNTIME;
1505 1830
1506 $map->load_header 1831 $map->load_header
1507 or return; 1832 or return;
1508 1833
1509 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1834 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1510 # doing this can freeze the server in a sync job, obviously 1835 # doing this can freeze the server in a sync job, obviously
1511 #$cf::WAIT_FOR_TICK->wait; 1836 #$cf::WAIT_FOR_TICK->wait;
1512 $map->reset; 1837 $map->reset;
1513 undef $guard; 1838 undef $guard;
1514 return find $path; 1839 return find $path;
1527 local $self->{deny_reset} = 1; # loading can take a long time 1852 local $self->{deny_reset} = 1; # loading can take a long time
1528 1853
1529 my $path = $self->{path}; 1854 my $path = $self->{path};
1530 1855
1531 { 1856 {
1857 my $guard1 = cf::lock_acquire "map_data:$path";
1532 my $guard = cf::lock_acquire "map_load:$path"; 1858 my $guard2 = cf::lock_acquire "map_load:$path";
1533 1859
1534 return if $self->in_memory != cf::MAP_SWAPPED; 1860 return if $self->in_memory != cf::MAP_SWAPPED;
1535 1861
1536 $self->in_memory (cf::MAP_LOADING); 1862 $self->in_memory (cf::MAP_LOADING);
1537 1863
1538 $self->alloc; 1864 $self->alloc;
1539 1865
1540 $self->pre_load; 1866 $self->pre_load;
1541 Coro::cede; 1867 cf::cede_to_tick;
1542 1868
1543 $self->_load_objects ($self->{load_path}, 1) 1869 $self->_load_objects ($self->{load_path}, 1)
1544 or return; 1870 or return;
1545 1871
1546 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1872 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1552 $self->clear_unique_items; 1878 $self->clear_unique_items;
1553 $self->_load_objects ($uniq, 0); 1879 $self->_load_objects ($uniq, 0);
1554 } 1880 }
1555 } 1881 }
1556 1882
1557 Coro::cede; 1883 cf::cede_to_tick;
1558 # now do the right thing for maps 1884 # now do the right thing for maps
1559 $self->link_multipart_objects; 1885 $self->link_multipart_objects;
1560 $self->difficulty ($self->estimate_difficulty) 1886 $self->difficulty ($self->estimate_difficulty)
1561 unless $self->difficulty; 1887 unless $self->difficulty;
1562 Coro::cede; 1888 cf::cede_to_tick;
1563 1889
1564 unless ($self->{deny_activate}) { 1890 unless ($self->{deny_activate}) {
1565 $self->decay_objects; 1891 $self->decay_objects;
1566 $self->fix_auto_apply; 1892 $self->fix_auto_apply;
1567 $self->update_buttons; 1893 $self->update_buttons;
1568 Coro::cede; 1894 cf::cede_to_tick;
1569 $self->set_darkness_map; 1895 $self->set_darkness_map;
1570 Coro::cede; 1896 cf::cede_to_tick;
1571 $self->activate; 1897 $self->activate;
1572 } 1898 }
1899
1900 $self->{last_save} = $cf::RUNTIME;
1901 $self->last_access ($cf::RUNTIME);
1573 1902
1574 $self->in_memory (cf::MAP_IN_MEMORY); 1903 $self->in_memory (cf::MAP_IN_MEMORY);
1575 } 1904 }
1576 1905
1577 $self->post_load; 1906 $self->post_load;
1581 my ($self, $ob) = @_; 1910 my ($self, $ob) = @_;
1582 1911
1583 return find "~" . $ob->name . "/" . $self->{path} 1912 return find "~" . $ob->name . "/" . $self->{path}
1584 if $self->per_player; 1913 if $self->per_player;
1585 1914
1915# return find "?party/" . $ob->name . "/" . $self->{path}
1916# if $self->per_party;
1917
1586 $self 1918 $self
1587} 1919}
1588 1920
1589# find and load all maps in the 3x3 area around a map 1921# find and load all maps in the 3x3 area around a map
1590sub load_diag { 1922sub load_neighbours {
1591 my ($map) = @_; 1923 my ($map) = @_;
1592 1924
1593 my @diag; # diagonal neighbours 1925 my @neigh; # diagonal neighbours
1594 1926
1595 for (0 .. 3) { 1927 for (0 .. 3) {
1596 my $neigh = $map->tile_path ($_) 1928 my $neigh = $map->tile_path ($_)
1597 or next; 1929 or next;
1598 $neigh = find $neigh, $map 1930 $neigh = find $neigh, $map
1599 or next; 1931 or next;
1600 $neigh->load; 1932 $neigh->load;
1601 1933
1934 push @neigh,
1602 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 1935 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1603 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 1936 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1604 } 1937 }
1605 1938
1606 for (@diag) { 1939 for (grep defined $_->[0], @neigh) {
1940 my ($path, $origin) = @$_;
1607 my $neigh = find @$_ 1941 my $neigh = find $path, $origin
1608 or next; 1942 or next;
1609 $neigh->load; 1943 $neigh->load;
1610 } 1944 }
1611} 1945}
1612 1946
1617} 1951}
1618 1952
1619sub do_load_sync { 1953sub do_load_sync {
1620 my ($map) = @_; 1954 my ($map) = @_;
1621 1955
1956 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
1957 if $Coro::current == $Coro::main;
1958
1622 cf::sync_job { $map->load }; 1959 cf::sync_job { $map->load };
1623} 1960}
1624 1961
1625our %MAP_PREFETCH; 1962our %MAP_PREFETCH;
1626our $MAP_PREFETCHER = undef; 1963our $MAP_PREFETCHER = undef;
1627 1964
1628sub find_async { 1965sub find_async {
1629 my ($path, $origin) = @_; 1966 my ($path, $origin, $load) = @_;
1630 1967
1631 $path = normalise $path, $origin && $origin->{path}; 1968 $path = normalise $path, $origin && $origin->{path};
1632 1969
1633 if (my $map = $cf::MAP{$path}) { 1970 if (my $map = $cf::MAP{$path}) {
1634 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1971 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1635 } 1972 }
1636 1973
1637 undef $MAP_PREFETCH{$path}; 1974 $MAP_PREFETCH{$path} |= $load;
1975
1638 $MAP_PREFETCHER ||= cf::async { 1976 $MAP_PREFETCHER ||= cf::async {
1639 while (%MAP_PREFETCH) { 1977 while (%MAP_PREFETCH) {
1640 for my $path (keys %MAP_PREFETCH) { 1978 while (my ($k, $v) = each %MAP_PREFETCH) {
1641 my $map = find $path 1979 if (my $map = find $k) {
1642 or next;
1643 $map->load; 1980 $map->load if $v;
1981 }
1644 1982
1645 delete $MAP_PREFETCH{$path}; 1983 delete $MAP_PREFETCH{$k};
1646 } 1984 }
1647 } 1985 }
1648 undef $MAP_PREFETCHER; 1986 undef $MAP_PREFETCHER;
1649 }; 1987 };
1650 $MAP_PREFETCHER->prio (6); 1988 $MAP_PREFETCHER->prio (6);
1653} 1991}
1654 1992
1655sub save { 1993sub save {
1656 my ($self) = @_; 1994 my ($self) = @_;
1657 1995
1658 my $lock = cf::lock_acquire "map_data:" . $self->path; 1996 my $lock = cf::lock_acquire "map_data:$self->{path}";
1659 1997
1660 $self->{last_save} = $cf::RUNTIME; 1998 $self->{last_save} = $cf::RUNTIME;
1661 1999
1662 return unless $self->dirty; 2000 return unless $self->dirty;
1663 2001
1686 my ($self) = @_; 2024 my ($self) = @_;
1687 2025
1688 # save first because save cedes 2026 # save first because save cedes
1689 $self->save; 2027 $self->save;
1690 2028
1691 my $lock = cf::lock_acquire "map_data:" . $self->path; 2029 my $lock = cf::lock_acquire "map_data:$self->{path}";
1692 2030
1693 return if $self->players; 2031 return if $self->players;
1694 return if $self->in_memory != cf::MAP_IN_MEMORY; 2032 return if $self->in_memory != cf::MAP_IN_MEMORY;
1695 return if $self->{deny_save}; 2033 return if $self->{deny_save};
1696 2034
1700 2038
1701sub reset_at { 2039sub reset_at {
1702 my ($self) = @_; 2040 my ($self) = @_;
1703 2041
1704 # TODO: safety, remove and allow resettable per-player maps 2042 # 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}; 2043 return 1e99 if $self->{deny_reset};
1707 2044
1708 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 2045 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1709 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 2046 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1710 2047
1721 my ($self) = @_; 2058 my ($self) = @_;
1722 2059
1723 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2060 my $lock = cf::lock_acquire "map_data:$self->{path}";
1724 2061
1725 return if $self->players; 2062 return if $self->players;
1726 return if $self->isa ("ext::map_per_player");#d#
1727 2063
1728 warn "resetting map ", $self->path;#d# 2064 warn "resetting map ", $self->path;
1729 2065
1730 $self->in_memory (cf::MAP_SWAPPED); 2066 $self->in_memory (cf::MAP_SWAPPED);
1731 2067
1732 # need to save uniques path 2068 # need to save uniques path
1733 unless ($self->{deny_save}) { 2069 unless ($self->{deny_save}) {
1750my $nuke_counter = "aaaa"; 2086my $nuke_counter = "aaaa";
1751 2087
1752sub nuke { 2088sub nuke {
1753 my ($self) = @_; 2089 my ($self) = @_;
1754 2090
2091 {
2092 my $lock = cf::lock_acquire "map_data:$self->{path}";
2093
1755 delete $cf::MAP{$self->path}; 2094 delete $cf::MAP{$self->path};
1756 2095
1757 $self->unlink_save; 2096 $self->unlink_save;
1758 2097
1759 bless $self, "cf::map"; 2098 bless $self, "cf::map";
1760 delete $self->{deny_reset}; 2099 delete $self->{deny_reset};
1761 $self->{deny_save} = 1; 2100 $self->{deny_save} = 1;
1762 $self->reset_timeout (1); 2101 $self->reset_timeout (1);
1763 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2102 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1764 2103
1765 $cf::MAP{$self->path} = $self; 2104 $cf::MAP{$self->path} = $self;
2105 }
1766 2106
1767 $self->reset; # polite request, might not happen 2107 $self->reset; # polite request, might not happen
2108}
2109
2110=item $maps = cf::map::tmp_maps
2111
2112Returns an arrayref with all map paths of currently instantiated and saved
2113maps. May block.
2114
2115=cut
2116
2117sub tmp_maps() {
2118 [
2119 map {
2120 utf8::decode $_;
2121 /\.map$/
2122 ? normalise $_
2123 : ()
2124 } @{ aio_readdir $TMPDIR or [] }
2125 ]
2126}
2127
2128=item $maps = cf::map::random_maps
2129
2130Returns an arrayref with all map paths of currently instantiated and saved
2131random maps. May block.
2132
2133=cut
2134
2135sub random_maps() {
2136 [
2137 map {
2138 utf8::decode $_;
2139 /\.map$/
2140 ? normalise "?random/$_"
2141 : ()
2142 } @{ aio_readdir $RANDOMDIR or [] }
2143 ]
1768} 2144}
1769 2145
1770=item cf::map::unique_maps 2146=item cf::map::unique_maps
1771 2147
1772Returns an arrayref of paths of all shared maps that have 2148Returns an arrayref of paths of all shared maps that have
1773instantiated unique items. May block. 2149instantiated unique items. May block.
1774 2150
1775=cut 2151=cut
1776 2152
1777sub unique_maps() { 2153sub unique_maps() {
1778 my $files = aio_readdir $UNIQUEDIR 2154 [
1779 or return; 2155 map {
1780
1781 my @paths;
1782
1783 for (@$files) {
1784 utf8::decode $_; 2156 utf8::decode $_;
1785 next if /\.pst$/; 2157 /\.map$/
1786 next unless /^$PATH_SEP/o; 2158 ? normalise $_
1787 2159 : ()
1788 push @paths, cf::map::normalise $_; 2160 } @{ aio_readdir $UNIQUEDIR or [] }
1789 } 2161 ]
1790
1791 \@paths
1792} 2162}
1793 2163
1794package cf; 2164package cf;
1795 2165
1796=back 2166=back
1842 2212
1843 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2213 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1844 2214
1845 if ($self->{record_replies}) { 2215 if ($self->{record_replies}) {
1846 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2216 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2217
1847 } else { 2218 } else {
2219 my $pl = $self->contr;
2220
2221 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2222 my $dialog = $pl->{npc_dialog};
2223 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2224
2225 } else {
1848 $msg = $npc->name . " says: $msg" if $npc; 2226 $msg = $npc->name . " says: $msg" if $npc;
1849 $self->message ($msg, $flags); 2227 $self->message ($msg, $flags);
2228 }
1850 } 2229 }
2230}
2231
2232=item $object->send_msg ($channel, $msg, $color, [extra...])
2233
2234=cut
2235
2236sub cf::object::send_msg {
2237 my $pl = shift->contr
2238 or return;
2239 $pl->send_msg (@_);
1851} 2240}
1852 2241
1853=item $player_object->may ("access") 2242=item $player_object->may ("access")
1854 2243
1855Returns wether the given player is authorized to access resource "access" 2244Returns wether the given player is authorized to access resource "access"
1902 $self->deactivate_recursive; 2291 $self->deactivate_recursive;
1903 2292
1904 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2293 return if UNIVERSAL::isa $self->map, "ext::map_link";
1905 2294
1906 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2295 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1907 if $self->map; 2296 if $self->map && $self->map->{path} ne "{link}";
1908 2297
1909 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2298 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1910} 2299}
1911 2300
1912sub cf::object::player::leave_link { 2301sub cf::object::player::leave_link {
1913 my ($self, $map, $x, $y) = @_; 2302 my ($self, $map, $x, $y) = @_;
2303
2304 return unless $self->contr->active;
1914 2305
1915 my $link_pos = delete $self->{_link_pos}; 2306 my $link_pos = delete $self->{_link_pos};
1916 2307
1917 unless ($map) { 2308 unless ($map) {
1918 # restore original map position 2309 # restore original map position
1932 # use -1 or undef as default coordinates, not 0, 0 2323 # use -1 or undef as default coordinates, not 0, 0
1933 ($x, $y) = ($map->enter_x, $map->enter_y) 2324 ($x, $y) = ($map->enter_x, $map->enter_y)
1934 if $x <=0 && $y <= 0; 2325 if $x <=0 && $y <= 0;
1935 2326
1936 $map->load; 2327 $map->load;
1937 $map->load_diag; 2328 $map->load_neighbours;
1938 2329
1939 return unless $self->contr->active; 2330 return unless $self->contr->active;
1940 $self->activate_recursive; 2331 $self->activate_recursive;
1941 2332
1942 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2333 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1943 $self->enter_map ($map, $x, $y); 2334 $self->enter_map ($map, $x, $y);
1944} 2335}
1945 2336
1946cf::player->attach ( 2337=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
1947 on_logout => sub {
1948 my ($pl) = @_;
1949 2338
1950 # abort map switching before logout 2339Moves the player to the given map-path and coordinates by first freezing
1951 if ($pl->ob->{_link_pos}) { 2340her, loading and preparing them map, calling the provided $check callback
1952 cf::sync_job { 2341that has to return the map if sucecssful, and then unfreezes the player on
1953 $pl->ob->leave_link 2342the new (success) or old (failed) map position. In either case, $done will
1954 }; 2343be called at the end of this process.
1955 }
1956 },
1957 on_login => sub {
1958 my ($pl) = @_;
1959 2344
1960 # try to abort aborted map switching on player login :)
1961 # should happen only on crashes
1962 if ($pl->ob->{_link_pos}) {
1963 $pl->ob->enter_link;
1964 (async {
1965 $pl->ob->reply (undef,
1966 "There was an internal problem at your last logout, "
1967 . "the server will try to bring you to your intended destination in a second.",
1968 cf::NDI_RED);
1969 # we need this sleep as the login has a concurrent enter_exit running
1970 # and this sleep increases chances of the player not ending up in scorn
1971 Coro::Timer::sleep 1;
1972 $pl->ob->leave_link;
1973 })->prio (2);
1974 }
1975 },
1976);
1977
1978=item $player_object->goto ($path, $x, $y)
1979
1980=cut 2345=cut
2346
2347our $GOTOGEN;
1981 2348
1982sub cf::object::player::goto { 2349sub cf::object::player::goto {
1983 my ($self, $path, $x, $y) = @_; 2350 my ($self, $path, $x, $y, $check, $done) = @_;
2351
2352 # do generation counting so two concurrent goto's will be executed in-order
2353 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1984 2354
1985 $self->enter_link; 2355 $self->enter_link;
1986 2356
1987 (async { 2357 (async {
1988 my $map = eval { 2358 my $map = eval {
1989 my $map = cf::map::find $path; 2359 my $map = cf::map::find $path;
2360
2361 if ($map) {
1990 $map = $map->customise_for ($self) if $map; 2362 $map = $map->customise_for ($self);
2363 $map = $check->($map) if $check && $map;
2364 } else {
2365 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2366 }
2367
1991 $map 2368 $map
2369 };
2370
2371 if ($@) {
2372 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2373 LOG llevError | logBacktrace, Carp::longmess $@;
1992 } or 2374 }
1993 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1994 2375
2376 if ($gen == $self->{_goto_generation}) {
2377 delete $self->{_goto_generation};
1995 $self->leave_link ($map, $x, $y); 2378 $self->leave_link ($map, $x, $y);
2379 }
2380
2381 $done->() if $done;
1996 })->prio (1); 2382 })->prio (1);
1997} 2383}
1998 2384
1999=item $player_object->enter_exit ($exit_object) 2385=item $player_object->enter_exit ($exit_object)
2000 2386
2069 my $hp = $exit->stats->hp; 2455 my $hp = $exit->stats->hp;
2070 my $sp = $exit->stats->sp; 2456 my $sp = $exit->stats->sp;
2071 2457
2072 $self->enter_link; 2458 $self->enter_link;
2073 2459
2460 # if exit is damned, update players death & WoR home-position
2461 $self->contr->savebed ($slaying, $hp, $sp)
2462 if $exit->flag (FLAG_DAMNED);
2463
2074 (async { 2464 (async {
2075 $self->deactivate_recursive; # just to be sure 2465 $self->deactivate_recursive; # just to be sure
2076 unless (eval { 2466 unless (eval {
2077 $self->goto ($slaying, $hp, $sp); 2467 $self->goto ($slaying, $hp, $sp);
2078 2468
2105 2495
2106 utf8::encode $text; 2496 utf8::encode $text;
2107 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2497 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2108} 2498}
2109 2499
2500=item $client->send_msg ($channel, $msg, $color, [extra...])
2501
2502Send a drawinfo or msg packet to the client, formatting the msg for the
2503client if neccessary. C<$type> should be a string identifying the type of
2504the message, with C<log> being the default. If C<$color> is negative, suppress
2505the message unless the client supports the msg packet.
2506
2507=cut
2508
2509our %CHANNEL = (
2510 "c/identify" => {
2511 id => "identify",
2512 title => "Identify",
2513 reply => undef,
2514 tooltip => "Items recently identified",
2515 },
2516);
2517
2518sub cf::client::send_msg {
2519 my ($self, $channel, $msg, $color, @extra) = @_;
2520
2521 $msg = $self->pl->expand_cfpod ($msg);
2522
2523 $color &= cf::NDI_CLIENT_MASK; # just in case...
2524
2525 # check predefined channels, for the benefit of C
2526 $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2527
2528 if (ref $channel) {
2529 # send meta info to client, if not yet sent
2530 unless (exists $self->{channel}{$channel->{id}}) {
2531 $self->{channel}{$channel->{id}} = $channel;
2532 $self->ext_msg (channel_info => $channel);
2533 }
2534
2535 $channel = $channel->{id};
2536 }
2537
2538 return unless @extra || length $msg;
2539
2540 if ($self->can_msg) {
2541 # default colour, mask it out
2542 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2543 if $color & cf::NDI_DEF;
2544
2545 $self->send_packet ("msg " . $self->{json_coder}->encode (
2546 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2547 } else {
2548 if ($color >= 0) {
2549 # replace some tags by gcfclient-compatible ones
2550 for ($msg) {
2551 1 while
2552 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2553 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2554 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2555 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2556 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2557 }
2558
2559 $color &= cf::NDI_COLOR_MASK;
2560
2561 utf8::encode $msg;
2562
2563 if (0 && $msg =~ /\[/) {
2564 # COMMAND/INFO
2565 $self->send_packet ("drawextinfo $color 10 8 $msg")
2566 } else {
2567 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2568 $self->send_packet ("drawinfo $color $msg")
2569 }
2570 }
2571 }
2572}
2573
2110=item $client->ext_event ($type, %msg) 2574=item $client->ext_msg ($type, @msg)
2111 2575
2112Sends an exti event to the client. 2576Sends an ext event to the client.
2113 2577
2114=cut 2578=cut
2115 2579
2116sub cf::client::ext_event($$%) { 2580sub cf::client::ext_msg($$@) {
2117 my ($self, $type, %msg) = @_; 2581 my ($self, $type, @msg) = @_;
2118 2582
2583 if ($self->extcmd == 2) {
2584 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2585 } elsif ($self->extcmd == 1) { # TODO: remove
2119 $msg{msgtype} = "event_$type"; 2586 push @msg, msgtype => "event_$type";
2120 $self->send_packet ("ext " . cf::to_json \%msg); 2587 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2588 }
2589}
2590
2591=item $client->ext_reply ($msgid, @msg)
2592
2593Sends an ext reply to the client.
2594
2595=cut
2596
2597sub cf::client::ext_reply($$@) {
2598 my ($self, $id, @msg) = @_;
2599
2600 if ($self->extcmd == 2) {
2601 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2602 } elsif ($self->extcmd == 1) {
2603 #TODO: version 1, remove
2604 unshift @msg, msgtype => "reply", msgid => $id;
2605 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2606 }
2121} 2607}
2122 2608
2123=item $success = $client->query ($flags, "text", \&cb) 2609=item $success = $client->query ($flags, "text", \&cb)
2124 2610
2125Queues a query to the client, calling the given callback with 2611Queues a query to the client, calling the given callback with
2126the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2612the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2127C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2613C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2128 2614
2129Queries can fail, so check the return code. Or don't, as queries will become 2615Queries can fail, so check the return code. Or don't, as queries will
2130reliable at some point in the future. 2616become reliable at some point in the future.
2131 2617
2132=cut 2618=cut
2133 2619
2134sub cf::client::query { 2620sub cf::client::query {
2135 my ($self, $flags, $text, $cb) = @_; 2621 my ($self, $flags, $text, $cb) = @_;
2143 utf8::encode $text; 2629 utf8::encode $text;
2144 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2630 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2145 2631
2146 $self->send_packet ($self->{query_queue}[0][0]) 2632 $self->send_packet ($self->{query_queue}[0][0])
2147 if @{ $self->{query_queue} } == 1; 2633 if @{ $self->{query_queue} } == 1;
2634
2635 1
2148} 2636}
2149 2637
2150cf::client->attach ( 2638cf::client->attach (
2639 on_connect => sub {
2640 my ($ns) = @_;
2641
2642 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2643 },
2151 on_reply => sub { 2644 on_reply => sub {
2152 my ($ns, $msg) = @_; 2645 my ($ns, $msg) = @_;
2153 2646
2154 # this weird shuffling is so that direct followup queries 2647 # this weird shuffling is so that direct followup queries
2155 # get handled first 2648 # get handled first
2167 } else { 2660 } else {
2168 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2661 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2169 } 2662 }
2170 } 2663 }
2171 }, 2664 },
2665 on_exticmd => sub {
2666 my ($ns, $buf) = @_;
2667
2668 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2669
2670 if (ref $msg) {
2671 my ($type, $reply, @payload) =
2672 "ARRAY" eq ref $msg
2673 ? @$msg
2674 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2675
2676 my @reply;
2677
2678 if (my $cb = $EXTICMD{$type}) {
2679 @reply = $cb->($ns, @payload);
2680 }
2681
2682 $ns->ext_reply ($reply, @reply)
2683 if $reply;
2684
2685 } else {
2686 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2687 }
2688
2689 cf::override;
2690 },
2172); 2691);
2173 2692
2174=item $client->async (\&cb) 2693=item $client->async (\&cb)
2175 2694
2176Create a new coroutine, running the specified callback. The coroutine will 2695Create a new coroutine, running the specified callback. The coroutine will
2217our $safe = new Safe "safe"; 2736our $safe = new Safe "safe";
2218our $safe_hole = new Safe::Hole; 2737our $safe_hole = new Safe::Hole;
2219 2738
2220$SIG{FPE} = 'IGNORE'; 2739$SIG{FPE} = 'IGNORE';
2221 2740
2222$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2741$safe->permit_only (Opcode::opset qw(
2742 :base_core :base_mem :base_orig :base_math
2743 grepstart grepwhile mapstart mapwhile
2744 sort time
2745));
2223 2746
2224# here we export the classes and methods available to script code 2747# here we export the classes and methods available to script code
2225 2748
2226=pod 2749=pod
2227 2750
2228The following functions and methods are available within a safe environment: 2751The following functions and methods are available within a safe environment:
2229 2752
2230 cf::object contr pay_amount pay_player map 2753 cf::object
2754 contr pay_amount pay_player map x y force_find force_add
2755 insert remove name archname title slaying race decrease_ob_nr
2756
2231 cf::object::player player 2757 cf::object::player
2232 cf::player peaceful 2758 player
2233 cf::map trigger 2759
2760 cf::player
2761 peaceful
2762
2763 cf::map
2764 trigger
2234 2765
2235=cut 2766=cut
2236 2767
2237for ( 2768for (
2238 ["cf::object" => qw(contr pay_amount pay_player map)], 2769 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2770 insert remove inv name archname title slaying race
2771 decrease_ob_nr)],
2239 ["cf::object::player" => qw(player)], 2772 ["cf::object::player" => qw(player)],
2240 ["cf::player" => qw(peaceful)], 2773 ["cf::player" => qw(peaceful)],
2241 ["cf::map" => qw(trigger)], 2774 ["cf::map" => qw(trigger)],
2242) { 2775) {
2243 no strict 'refs'; 2776 no strict 'refs';
2314=back 2847=back
2315 2848
2316=cut 2849=cut
2317 2850
2318############################################################################# 2851#############################################################################
2319
2320=head2 EXTENSION DATABASE SUPPORT
2321
2322Crossfire maintains a very simple database for extension use. It can
2323currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2324convert to/from binary).
2325
2326The parameter C<$family> should best start with the name of the extension
2327using it, it should be unique.
2328
2329=over 4
2330
2331=item $value = cf::db_get $family => $key
2332
2333Returns a single value from the database.
2334
2335=item cf::db_put $family => $key => $value
2336
2337Stores the given C<$value> in the family.
2338
2339=cut
2340
2341our $DB;
2342
2343sub db_init {
2344 unless ($DB) {
2345 $DB = BDB::db_create $DB_ENV;
2346
2347 cf::sync_job {
2348 eval {
2349 $DB->set_flags (BDB::CHKSUM);
2350
2351 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2352 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2353 cf::cleanup "db_open(db): $!" if $!;
2354 };
2355 cf::cleanup "db_open(db): $@" if $@;
2356 };
2357 }
2358}
2359
2360sub db_get($$) {
2361 my $key = "$_[0]/$_[1]";
2362
2363 cf::sync_job {
2364 BDB::db_get $DB, undef, $key, my $data;
2365
2366 $! ? ()
2367 : $data
2368 }
2369}
2370
2371sub db_put($$$) {
2372 BDB::dbreq_pri 4;
2373 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2374}
2375
2376=item cf::cache $id => [$paths...], $processversion => $process
2377
2378Generic caching function that returns the value of the resource $id,
2379caching and regenerating as required.
2380
2381This function can block.
2382
2383=cut
2384
2385sub cache {
2386 my ($id, $src, $processversion, $process) = @_;
2387
2388 my $meta =
2389 join "\x00",
2390 $processversion,
2391 map {
2392 aio_stat $_
2393 and Carp::croak "$_: $!";
2394
2395 ($_, (stat _)[7,9])
2396 } @$src;
2397
2398 my $dbmeta = db_get cache => "$id/meta";
2399 if ($dbmeta ne $meta) {
2400 # changed, we may need to process
2401
2402 my @data;
2403 my $md5;
2404
2405 for (0 .. $#$src) {
2406 0 <= aio_load $src->[$_], $data[$_]
2407 or Carp::croak "$src->[$_]: $!";
2408 }
2409
2410 # if processing is expensive, check
2411 # checksum first
2412 if (1) {
2413 $md5 =
2414 join "\x00",
2415 $processversion,
2416 map {
2417 Coro::cede;
2418 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2419 } 0.. $#$src;
2420
2421
2422 my $dbmd5 = db_get cache => "$id/md5";
2423 if ($dbmd5 eq $md5) {
2424 db_put cache => "$id/meta", $meta;
2425
2426 return db_get cache => "$id/data";
2427 }
2428 }
2429
2430 my $t1 = Time::HiRes::time;
2431 my $data = $process->(\@data);
2432 my $t2 = Time::HiRes::time;
2433
2434 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2435
2436 db_put cache => "$id/data", $data;
2437 db_put cache => "$id/md5" , $md5;
2438 db_put cache => "$id/meta", $meta;
2439
2440 return $data;
2441 }
2442
2443 db_get cache => "$id/data"
2444}
2445
2446=item fork_call { }, $args
2447
2448Executes the given code block with the given arguments in a seperate
2449process, returning the results. Everything must be serialisable with
2450Coro::Storable. May, of course, block. Note that the executed sub may
2451never block itself or use any form of Event handling.
2452
2453=cut
2454
2455sub fork_call(&@) {
2456 my ($cb, @args) = @_;
2457
2458# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2459# or die "socketpair: $!";
2460 pipe my $fh1, my $fh2
2461 or die "pipe: $!";
2462
2463 if (my $pid = fork) {
2464 close $fh2;
2465
2466 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2467 $res = Coro::Storable::thaw $res;
2468
2469 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2470
2471 die $$res unless "ARRAY" eq ref $res;
2472
2473 return wantarray ? @$res : $res->[-1];
2474 } else {
2475 reset_signals;
2476 local $SIG{__WARN__};
2477 local $SIG{__DIE__};
2478 eval {
2479 close $fh1;
2480
2481 my @res = eval { $cb->(@args) };
2482 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2483 };
2484
2485 warn $@ if $@;
2486 _exit 0;
2487 }
2488}
2489
2490
2491
2492#############################################################################
2493# the server's init and main functions 2852# the server's init and main functions
2494 2853
2495sub load_facedata($) { 2854sub load_facedata($) {
2496 my ($path) = @_; 2855 my ($path) = @_;
2856
2857 # HACK to clear player env face cache, we need some signal framework
2858 # for this (global event?)
2859 %ext::player_env::MUSIC_FACE_CACHE = ();
2860
2861 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2497 2862
2498 warn "loading facedata from $path\n"; 2863 warn "loading facedata from $path\n";
2499 2864
2500 my $facedata; 2865 my $facedata;
2501 0 < aio_load $path, $facedata 2866 0 < aio_load $path, $facedata
2504 $facedata = Coro::Storable::thaw $facedata; 2869 $facedata = Coro::Storable::thaw $facedata;
2505 2870
2506 $facedata->{version} == 2 2871 $facedata->{version} == 2
2507 or cf::cleanup "$path: version mismatch, cannot proceed."; 2872 or cf::cleanup "$path: version mismatch, cannot proceed.";
2508 2873
2874 # patch in the exptable
2875 $facedata->{resource}{"res/exp_table"} = {
2876 type => FT_RSRC,
2877 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
2878 };
2879 cf::cede_to_tick;
2880
2509 { 2881 {
2510 my $faces = $facedata->{faceinfo}; 2882 my $faces = $facedata->{faceinfo};
2511 2883
2512 while (my ($face, $info) = each %$faces) { 2884 while (my ($face, $info) = each %$faces) {
2513 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2885 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2514 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2886 cf::face::set_visibility $idx, $info->{visibility};
2887 cf::face::set_magicmap $idx, $info->{magicmap};
2515 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2888 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2516 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2889 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2517 Coro::cede; 2890
2891 cf::cede_to_tick;
2518 } 2892 }
2519 2893
2520 while (my ($face, $info) = each %$faces) { 2894 while (my ($face, $info) = each %$faces) {
2521 next unless $info->{smooth}; 2895 next unless $info->{smooth};
2522 my $idx = cf::face::find $face 2896 my $idx = cf::face::find $face
2523 or next; 2897 or next;
2524 if (my $smooth = cf::face::find $info->{smooth}) { 2898 if (my $smooth = cf::face::find $info->{smooth}) {
2899 cf::face::set_smooth $idx, $smooth;
2525 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2900 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2526 } else { 2901 } else {
2527 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2902 warn "smooth face '$info->{smooth}' not found for face '$face'";
2528 } 2903 }
2529 Coro::cede; 2904
2905 cf::cede_to_tick;
2530 } 2906 }
2531 } 2907 }
2532 2908
2533 { 2909 {
2534 my $anims = $facedata->{animinfo}; 2910 my $anims = $facedata->{animinfo};
2535 2911
2536 while (my ($anim, $info) = each %$anims) { 2912 while (my ($anim, $info) = each %$anims) {
2537 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2913 cf::anim::set $anim, $info->{frames}, $info->{facings};
2538 Coro::cede; 2914 cf::cede_to_tick;
2539 } 2915 }
2540 2916
2541 cf::anim::invalidate_all; # d'oh 2917 cf::anim::invalidate_all; # d'oh
2542 } 2918 }
2543 2919
2920 {
2921 # TODO: for gcfclient pleasure, we should give resources
2922 # that gcfclient doesn't grok a >10000 face index.
2923 my $res = $facedata->{resource};
2924
2925 my $soundconf = delete $res->{"res/sound.conf"};
2926
2927 while (my ($name, $info) = each %$res) {
2928 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2929 my $data;
2930
2931 if ($info->{type} & 1) {
2932 # prepend meta info
2933
2934 my $meta = $enc->encode ({
2935 name => $name,
2936 %{ $info->{meta} || {} },
2937 });
2938
2939 $data = pack "(w/a*)*", $meta, $info->{data};
2940 } else {
2941 $data = $info->{data};
2942 }
2943
2944 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2945 cf::face::set_type $idx, $info->{type};
2946
2947 cf::cede_to_tick;
2948 }
2949
2950 if ($soundconf) {
2951 $soundconf = $enc->decode (delete $soundconf->{data});
2952
2953 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2954 my $sound = $soundconf->{compat}[$_]
2955 or next;
2956
2957 my $face = cf::face::find "sound/$sound->[1]";
2958 cf::sound::set $sound->[0] => $face;
2959 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2960 }
2961
2962 while (my ($k, $v) = each %{$soundconf->{event}}) {
2963 my $face = cf::face::find "sound/$v";
2964 cf::sound::set $k => $face;
2965 }
2966 }
2967 }
2968
2544 1 2969 1
2545} 2970}
2546 2971
2972register_exticmd fx_want => sub {
2973 my ($ns, $want) = @_;
2974
2975 while (my ($k, $v) = each %$want) {
2976 $ns->fx_want ($k, $v);
2977 }
2978};
2979
2547sub reload_regions { 2980sub reload_regions {
2981 # HACK to clear player env face cache, we need some signal framework
2982 # for this (global event?)
2983 %ext::player_env::MUSIC_FACE_CACHE = ();
2984
2548 load_resource_file "$MAPDIR/regions" 2985 load_resource_file "$MAPDIR/regions"
2549 or die "unable to load regions file\n"; 2986 or die "unable to load regions file\n";
2987
2988 for (cf::region::list) {
2989 $_->{match} = qr/$_->{match}/
2990 if exists $_->{match};
2991 }
2550} 2992}
2551 2993
2552sub reload_facedata { 2994sub reload_facedata {
2553 load_facedata "$DATADIR/facedata" 2995 load_facedata "$DATADIR/facedata"
2554 or die "unable to load facedata\n"; 2996 or die "unable to load facedata\n";
2555} 2997}
2556 2998
2557sub reload_archetypes { 2999sub reload_archetypes {
2558 load_resource_file "$DATADIR/archetypes" 3000 load_resource_file "$DATADIR/archetypes"
2559 or die "unable to load archetypes\n"; 3001 or die "unable to load archetypes\n";
3002 #d# NEED to laod twice to resolve forward references
3003 # this really needs to be done in an extra post-pass
3004 # (which needs to be synchronous, so solve it differently)
3005 load_resource_file "$DATADIR/archetypes"
3006 or die "unable to load archetypes\n";
2560} 3007}
2561 3008
2562sub reload_treasures { 3009sub reload_treasures {
2563 load_resource_file "$DATADIR/treasures" 3010 load_resource_file "$DATADIR/treasures"
2564 or die "unable to load treasurelists\n"; 3011 or die "unable to load treasurelists\n";
2567sub reload_resources { 3014sub reload_resources {
2568 warn "reloading resource files...\n"; 3015 warn "reloading resource files...\n";
2569 3016
2570 reload_regions; 3017 reload_regions;
2571 reload_facedata; 3018 reload_facedata;
3019 #reload_archetypes;#d#
2572 reload_archetypes; 3020 reload_archetypes;
2573 reload_treasures; 3021 reload_treasures;
2574 3022
2575 warn "finished reloading resource files\n"; 3023 warn "finished reloading resource files\n";
2576} 3024}
2577 3025
2578sub init { 3026sub init {
2579 reload_resources; 3027 reload_resources;
2580} 3028}
2581 3029
2582sub cfg_load { 3030sub reload_config {
2583 open my $fh, "<:utf8", "$CONFDIR/config" 3031 open my $fh, "<:utf8", "$CONFDIR/config"
2584 or return; 3032 or return;
2585 3033
2586 local $/; 3034 local $/;
2587 *CFG = YAML::Syck::Load <$fh>; 3035 *CFG = YAML::Syck::Load <$fh>;
2607 (async { 3055 (async {
2608 Event::one_event; 3056 Event::one_event;
2609 })->prio (Coro::PRIO_MAX); 3057 })->prio (Coro::PRIO_MAX);
2610 }; 3058 };
2611 3059
2612 cfg_load; 3060 reload_config;
2613 db_init; 3061 db_init;
2614 load_extensions; 3062 load_extensions;
2615 3063
2616 $TICK_WATCHER->start; 3064 $TICK_WATCHER->start;
2617 Event::loop; 3065 Event::loop;
2633 }, 3081 },
2634 ); 3082 );
2635 } 3083 }
2636} 3084}
2637 3085
3086sub write_runtime {
3087 my $runtime = "$LOCALDIR/runtime";
3088
3089 # first touch the runtime file to show we are still running:
3090 # the fsync below can take a very very long time.
3091
3092 IO::AIO::aio_utime $runtime, undef, undef;
3093
3094 my $guard = cf::lock_acquire "write_runtime";
3095
3096 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
3097 or return;
3098
3099 my $value = $cf::RUNTIME + 90 + 10;
3100 # 10 is the runtime save interval, for a monotonic clock
3101 # 60 allows for the watchdog to kill the server.
3102
3103 (aio_write $fh, 0, (length $value), $value, 0) <= 0
3104 and return;
3105
3106 # always fsync - this file is important
3107 aio_fsync $fh
3108 and return;
3109
3110 # touch it again to show we are up-to-date
3111 aio_utime $fh, undef, undef;
3112
3113 close $fh
3114 or return;
3115
3116 aio_rename "$runtime~", $runtime
3117 and return;
3118
3119 warn "runtime file written.\n";
3120
3121 1
3122}
3123
2638sub emergency_save() { 3124sub emergency_save() {
2639 my $freeze_guard = cf::freeze_mainloop; 3125 my $freeze_guard = cf::freeze_mainloop;
2640 3126
2641 warn "enter emergency perl save\n"; 3127 warn "enter emergency perl save\n";
2642 3128
2717 %EXT_CORO = (); 3203 %EXT_CORO = ();
2718 3204
2719 warn "removing commands"; 3205 warn "removing commands";
2720 %COMMAND = (); 3206 %COMMAND = ();
2721 3207
2722 warn "removing ext commands"; 3208 warn "removing ext/exti commands";
2723 %EXTCMD = (); 3209 %EXTCMD = ();
3210 %EXTICMD = ();
2724 3211
2725 warn "unloading/nuking all extensions"; 3212 warn "unloading/nuking all extensions";
2726 for my $pkg (@EXTS) { 3213 for my $pkg (@EXTS) {
2727 warn "... unloading $pkg"; 3214 warn "... unloading $pkg";
2728 3215
2771 warn "reloading cf.pm"; 3258 warn "reloading cf.pm";
2772 require cf; 3259 require cf;
2773 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3260 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2774 3261
2775 warn "loading config and database again"; 3262 warn "loading config and database again";
2776 cf::cfg_load; 3263 cf::reload_config;
2777 3264
2778 warn "loading extensions"; 3265 warn "loading extensions";
2779 cf::load_extensions; 3266 cf::load_extensions;
2780 3267
2781 warn "reattaching attachments to objects/players"; 3268 warn "reattaching attachments to objects/players";
2846 my $signal = new Coro::Signal; 3333 my $signal = new Coro::Signal;
2847 push @WAIT_FOR_TICK_BEGIN, $signal; 3334 push @WAIT_FOR_TICK_BEGIN, $signal;
2848 $signal->wait; 3335 $signal->wait;
2849} 3336}
2850 3337
3338 my $min = 1e6;#d#
3339 my $avg = 10;
2851$TICK_WATCHER = Event->timer ( 3340$TICK_WATCHER = Event->timer (
2852 reentrant => 0, 3341 reentrant => 0,
2853 parked => 1, 3342 parked => 1,
2854 prio => 0, 3343 prio => 0,
2855 at => $NEXT_TICK || $TICK, 3344 at => $NEXT_TICK || $TICK,
2862 } 3351 }
2863 3352
2864 $NOW = $tick_start = Event::time; 3353 $NOW = $tick_start = Event::time;
2865 3354
2866 cf::server_tick; # one server iteration 3355 cf::server_tick; # one server iteration
3356
3357 0 && sync_job {#d#
3358 for(1..10) {
3359 my $t = Event::time;
3360 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3361 or die;
3362
3363 $map->width (50);
3364 $map->height (50);
3365 $map->alloc;
3366 $map->_load_objects ("/tmp/x.map", 1);
3367 my $t = Event::time - $t;
3368
3369 #next unless $t < 0.0013;#d#
3370 if ($t < $min) {
3371 $min = $t;
3372 }
3373 $avg = $avg * 0.99 + $t * 0.01;
3374 }
3375 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3376 exit 0;
3377 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3378 };
2867 3379
2868 $RUNTIME += $TICK; 3380 $RUNTIME += $TICK;
2869 $NEXT_TICK += $TICK; 3381 $NEXT_TICK += $TICK;
2870 3382
2871 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3383 if ($NOW >= $NEXT_RUNTIME_WRITE) {

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines