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.258 by root, Sat Apr 21 17:43:42 2007 UTC vs.
Revision 1.303 by root, Wed Jul 11 15:57:31 2007 UTC

… …
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable; 23use Coro::Storable;
24 24
25use JSON::XS 1.4 ();
25use BDB (); 26use BDB ();
26use Data::Dumper; 27use Data::Dumper;
27use Digest::MD5; 28use Digest::MD5;
28use Fcntl; 29use Fcntl;
29use YAML::Syck (); 30use YAML::Syck ();
30use IO::AIO 2.32 (); 31use IO::AIO 2.32 ();
31use Time::HiRes; 32use Time::HiRes;
32use Compress::LZF; 33use Compress::LZF;
34use Digest::MD5 ();
33 35
34# configure various modules to our taste 36# configure various modules to our taste
35# 37#
36$Storable::canonical = 1; # reduce rsync transfers 38$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 39Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
… …
49our %COMMAND = (); 51our %COMMAND = ();
50our %COMMAND_TIME = (); 52our %COMMAND_TIME = ();
51 53
52our @EXTS = (); # list of extension package names 54our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 55our %EXTCMD = ();
56our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 57our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 58our %EXT_MAP = (); # pluggable maps
56 59
57our $RELOAD; # number of reloads so far 60our $RELOAD; # number of reloads so far
58our @EVENT; 61our @EVENT;
… …
90our $LINK_MAP; # the special {link} map, which is always available 93our $LINK_MAP; # the special {link} map, which is always available
91 94
92# used to convert map paths into valid unix filenames by replacing / by ∕ 95# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 96our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 97
98our $LOAD; # a number between 0 (idle) and 1 (too many objects)
99our $LOADAVG; # same thing, but with alpha-smoothing
100our $tick_start; # for load detecting purposes
101
95binmode STDOUT; 102binmode STDOUT;
96binmode STDERR; 103binmode STDERR;
97 104
98# read virtual server time, if available 105# read virtual server time, if available
99unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 106unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
… …
139 146
140=item $cf::TICK 147=item $cf::TICK
141 148
142The interval between server ticks, in seconds. 149The interval between server ticks, in seconds.
143 150
151=item $cf::LOADAVG
152
153The current CPU load on the server (alpha-smoothed), as a value between 0
154(none) and 1 (overloaded), indicating how much time is spent on processing
155objects per tick. Healthy values are < 0.5.
156
157=item $cf::LOAD
158
159The raw value load value from the last tick.
160
144=item %cf::CFG 161=item %cf::CFG
145 162
146Configuration for the server, loaded from C</etc/crossfire/config>, or 163Configuration for the server, loaded from C</etc/crossfire/config>, or
147from wherever your confdir points to. 164from wherever your confdir points to.
148 165
… …
173@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 190@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
174@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 191@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
175@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 192@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
176@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 193@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
177@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 194@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
195@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
178@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 196@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
179 197
180# we bless all objects into (empty) derived classes to force a method lookup 198# we bless all objects into (empty) derived classes to force a method lookup
181# within the Safe compartment. 199# within the Safe compartment.
182for my $pkg (qw( 200for my $pkg (qw(
183 cf::global cf::attachable 201 cf::global cf::attachable
… …
191} 209}
192 210
193$Event::DIED = sub { 211$Event::DIED = sub {
194 warn "error in event callback: @_"; 212 warn "error in event callback: @_";
195}; 213};
214
215#############################################################################
196 216
197=head2 UTILITY FUNCTIONS 217=head2 UTILITY FUNCTIONS
198 218
199=over 4 219=over 4
200 220
… …
219 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 239 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
220 $d 240 $d
221 } || "[unable to dump $_[0]: '$@']"; 241 } || "[unable to dump $_[0]: '$@']";
222} 242}
223 243
224use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
225
226=item $ref = cf::from_json $json 244=item $ref = cf::from_json $json
227 245
228Converts a JSON string into the corresponding perl data structure. 246Converts a JSON string into the corresponding perl data structure.
229 247
230=item $json = cf::to_json $ref 248=item $json = cf::to_json $ref
231 249
232Converts a perl data structure into its JSON representation. 250Converts a perl data structure into its JSON representation.
251
252=cut
253
254our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
255
256sub to_json ($) { $json_coder->encode ($_[0]) }
257sub from_json ($) { $json_coder->decode ($_[0]) }
233 258
234=item cf::lock_wait $string 259=item cf::lock_wait $string
235 260
236Wait until the given lock is available. See cf::lock_acquire. 261Wait until the given lock is available. See cf::lock_acquire.
237 262
… …
303 328
304BEGIN { *async = \&Coro::async_pool } 329BEGIN { *async = \&Coro::async_pool }
305 330
306=item cf::sync_job { BLOCK } 331=item cf::sync_job { BLOCK }
307 332
308The design of crossfire+ requires that the main coro ($Coro::main) is 333The design of Crossfire TRT requires that the main coroutine ($Coro::main)
309always able to handle events or runnable, as crossfire+ is only partly 334is always able to handle events or runnable, as Crossfire TRT is only
310reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 335partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
336acceptable.
311 337
312If it must be done, put the blocking parts into C<sync_job>. This will run 338If it must be done, put the blocking parts into C<sync_job>. This will run
313the given BLOCK in another coroutine while waiting for the result. The 339the given BLOCK in another coroutine while waiting for the result. The
314server will be frozen during this time, so the block should either finish 340server will be frozen during this time, so the block should either finish
315fast or be very important. 341fast or be very important.
… …
318 344
319sub sync_job(&) { 345sub sync_job(&) {
320 my ($job) = @_; 346 my ($job) = @_;
321 347
322 if ($Coro::current == $Coro::main) { 348 if ($Coro::current == $Coro::main) {
349 my $time = Event::time;
350
323 # this is the main coro, too bad, we have to block 351 # this is the main coro, too bad, we have to block
324 # till the operation succeeds, freezing the server :/ 352 # till the operation succeeds, freezing the server :/
325 353
326 # TODO: use suspend/resume instead 354 # TODO: use suspend/resume instead
327 # (but this is cancel-safe) 355 # (but this is cancel-safe)
… …
338 366
339 while ($busy) { 367 while ($busy) {
340 Coro::cede or Event::one_event; 368 Coro::cede or Event::one_event;
341 } 369 }
342 370
371 $time = Event::time - $time;
372
373 LOG llevError | logBacktrace, Carp::longmess "long sync job"
374 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
375
376 $tick_start += $time; # do not account sync jobs to server load
377
343 wantarray ? @res : $res[0] 378 wantarray ? @res : $res[0]
344 } else { 379 } else {
345 # we are in another coroutine, how wonderful, everything just works 380 # we are in another coroutine, how wonderful, everything just works
346 381
347 $job->() 382 $job->()
… …
366 $EXT_CORO{$coro+0} = $coro; 401 $EXT_CORO{$coro+0} = $coro;
367 402
368 $coro 403 $coro
369} 404}
370 405
371sub write_runtime { 406=item fork_call { }, $args
372 my $guard = cf::lock_acquire "write_runtime";
373 407
374 my $runtime = "$LOCALDIR/runtime"; 408Executes the given code block with the given arguments in a seperate
409process, returning the results. Everything must be serialisable with
410Coro::Storable. May, of course, block. Note that the executed sub may
411never block itself or use any form of Event handling.
375 412
376 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 413=cut
377 or return;
378 414
379 my $value = $cf::RUNTIME + 90 + 10; 415sub _store_scalar {
380 # 10 is the runtime save interval, for a monotonic clock 416 open my $fh, ">", \my $buf
381 # 60 allows for the watchdog to kill the server. 417 or die "fork_call: cannot open fh-to-buf in child : $!";
382 418 Storable::store_fd $_[0], $fh;
383 (aio_write $fh, 0, (length $value), $value, 0) <= 0
384 and return;
385
386 # always fsync - this file is important
387 aio_fsync $fh
388 and return;
389
390 close $fh 419 close $fh;
391 or return;
392 420
393 aio_rename "$runtime~", $runtime 421 $buf
394 and return; 422}
395 423
424sub fork_call(&@) {
425 my ($cb, @args) = @_;
426
427# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
428# or die "socketpair: $!";
429 pipe my $fh1, my $fh2
430 or die "pipe: $!";
431
432 if (my $pid = fork) {
433 close $fh2;
434
435 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
436 warn "pst<$res>" unless $res =~ /^pst/;
437 $res = Coro::Storable::thaw $res;
438
439 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
440
441 Carp::confess $$res unless "ARRAY" eq ref $res;
442
443 return wantarray ? @$res : $res->[-1];
444 } else {
445 reset_signals;
446 local $SIG{__WARN__};
447 local $SIG{__DIE__};
448 # just in case, this hack effectively disables event
449 # in the child. cleaner and slower would be canceling all watchers,
450 # but this works for the time being.
451 local $Coro::idle;
452 $Coro::current->prio (Coro::PRIO_MAX);
453
454 eval {
455 close $fh1;
456
457 my @res = eval { $cb->(@args) };
458
459 syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
460 close $fh2;
461 };
462
463 warn $@ if $@;
464 _exit 0;
396 1 465 }
466}
467
468=item $value = cf::db_get $family => $key
469
470Returns a single value from the environment database.
471
472=item cf::db_put $family => $key => $value
473
474Stores the given C<$value> in the family. It can currently store binary
475data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
476
477=cut
478
479our $DB;
480
481sub db_init {
482 unless ($DB) {
483 $DB = BDB::db_create $DB_ENV;
484
485 cf::sync_job {
486 eval {
487 $DB->set_flags (BDB::CHKSUM);
488
489 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
490 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
491 cf::cleanup "db_open(db): $!" if $!;
492 };
493 cf::cleanup "db_open(db): $@" if $@;
494 };
495 }
496}
497
498sub db_get($$) {
499 my $key = "$_[0]/$_[1]";
500
501 cf::sync_job {
502 BDB::db_get $DB, undef, $key, my $data;
503
504 $! ? ()
505 : $data
506 }
507}
508
509sub db_put($$$) {
510 BDB::dbreq_pri 4;
511 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
512}
513
514=item cf::cache $id => [$paths...], $processversion => $process
515
516Generic caching function that returns the value of the resource $id,
517caching and regenerating as required.
518
519This function can block.
520
521=cut
522
523sub cache {
524 my ($id, $src, $processversion, $process) = @_;
525
526 my $meta =
527 join "\x00",
528 $processversion,
529 map {
530 aio_stat $_
531 and Carp::croak "$_: $!";
532
533 ($_, (stat _)[7,9])
534 } @$src;
535
536 my $dbmeta = db_get cache => "$id/meta";
537 if ($dbmeta ne $meta) {
538 # changed, we may need to process
539
540 my @data;
541 my $md5;
542
543 for (0 .. $#$src) {
544 0 <= aio_load $src->[$_], $data[$_]
545 or Carp::croak "$src->[$_]: $!";
546 }
547
548 # if processing is expensive, check
549 # checksum first
550 if (1) {
551 $md5 =
552 join "\x00",
553 $processversion,
554 map {
555 Coro::cede;
556 ($src->[$_], Digest::MD5::md5_hex $data[$_])
557 } 0.. $#$src;
558
559
560 my $dbmd5 = db_get cache => "$id/md5";
561 if ($dbmd5 eq $md5) {
562 db_put cache => "$id/meta", $meta;
563
564 return db_get cache => "$id/data";
565 }
566 }
567
568 my $t1 = Time::HiRes::time;
569 my $data = $process->(\@data);
570 my $t2 = Time::HiRes::time;
571
572 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
573
574 db_put cache => "$id/data", $data;
575 db_put cache => "$id/md5" , $md5;
576 db_put cache => "$id/meta", $meta;
577
578 return $data;
579 }
580
581 db_get cache => "$id/data"
397} 582}
398 583
399=item cf::datalog type => key => value, ... 584=item cf::datalog type => key => value, ...
400 585
401Log a datalog packet of the given type with the given key-value pairs. 586Log a datalog packet of the given type with the given key-value pairs.
… …
419attach callbacks/event handlers (a collection of which is called an "attachment") 604attach callbacks/event handlers (a collection of which is called an "attachment")
420to it. All such attachable objects support the following methods. 605to it. All such attachable objects support the following methods.
421 606
422In the following description, CLASS can be any of C<global>, C<object> 607In the following description, CLASS can be any of C<global>, C<object>
423C<player>, C<client> or C<map> (i.e. the attachable objects in 608C<player>, C<client> or C<map> (i.e. the attachable objects in
424crossfire+). 609Crossfire TRT).
425 610
426=over 4 611=over 4
427 612
428=item $attachable->attach ($attachment, key => $value...) 613=item $attachable->attach ($attachment, key => $value...)
429 614
… …
592 $registry = $CB_TYPE[$object_type] ||= []; 777 $registry = $CB_TYPE[$object_type] ||= [];
593 778
594 } elsif ($type eq "subtype") { 779 } elsif ($type eq "subtype") {
595 defined $object_type or Carp::croak "subtype specified without type"; 780 defined $object_type or Carp::croak "subtype specified without type";
596 my $object_subtype = shift @arg; 781 my $object_subtype = shift @arg;
597 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 782 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
598 783
599 } elsif ($type eq "package") { 784 } elsif ($type eq "package") {
600 my $pkg = shift @arg; 785 my $pkg = shift @arg;
601 786
602 while (my ($name, $id) = each %cb_id) { 787 while (my ($name, $id) = each %cb_id) {
… …
631 _attach $registry, $klass, @attach; 816 _attach $registry, $klass, @attach;
632 } 817 }
633 818
634 $obj->{$name} = \%arg; 819 $obj->{$name} = \%arg;
635 } else { 820 } else {
636 warn "object uses attachment '$name' that is not available, postponing.\n"; 821 warn "object uses attachment '$name' which is not available, postponing.\n";
637 } 822 }
638 823
639 $obj->{_attachment}{$name} = undef; 824 $obj->{_attachment}{$name} = undef;
640} 825}
641 826
… …
643 if (ref $_[0]) { 828 if (ref $_[0]) {
644 _object_attach @_; 829 _object_attach @_;
645 } else { 830 } else {
646 _attach shift->_attach_registry, @_; 831 _attach shift->_attach_registry, @_;
647 } 832 }
833 _recalc_want;
648}; 834};
649 835
650# all those should be optimised 836# all those should be optimised
651sub cf::attachable::detach { 837sub cf::attachable::detach {
652 my ($obj, $name) = @_; 838 my ($obj, $name) = @_;
… …
655 delete $obj->{_attachment}{$name}; 841 delete $obj->{_attachment}{$name};
656 reattach ($obj); 842 reattach ($obj);
657 } else { 843 } else {
658 Carp::croak "cannot, currently, detach class attachments"; 844 Carp::croak "cannot, currently, detach class attachments";
659 } 845 }
846 _recalc_want;
660}; 847};
661 848
662sub cf::attachable::attached { 849sub cf::attachable::attached {
663 my ($obj, $name) = @_; 850 my ($obj, $name) = @_;
664 851
… …
837 or return; 1024 or return;
838 $av = eval { (Storable::thaw $av)->{objs} }; 1025 $av = eval { (Storable::thaw $av)->{objs} };
839 } 1026 }
840 1027
841 warn sprintf "loading %s (%d)\n", 1028 warn sprintf "loading %s (%d)\n",
842 $filename, length $data, scalar @{$av || []};#d# 1029 $filename, length $data, scalar @{$av || []};
843 return ($data, $av); 1030 return ($data, $av);
844} 1031}
1032
1033=head2 COMMAND CALLBACKS
1034
1035=over 4
1036
1037=cut
845 1038
846############################################################################# 1039#############################################################################
847# command handling &c 1040# command handling &c
848 1041
849=item cf::register_command $name => \&callback($ob,$args); 1042=item cf::register_command $name => \&callback($ob,$args);
… …
862 push @{ $COMMAND{$name} }, [$caller, $cb]; 1055 push @{ $COMMAND{$name} }, [$caller, $cb];
863} 1056}
864 1057
865=item cf::register_extcmd $name => \&callback($pl,$packet); 1058=item cf::register_extcmd $name => \&callback($pl,$packet);
866 1059
867Register a callbackf ro execution when the client sends an extcmd packet. 1060Register a callback for execution when the client sends an (synchronous)
1061extcmd packet. Ext commands will be processed in the order they are
1062received by the server, like other user commands. The first argument is
1063the logged-in player. Ext commands can only be processed after a player
1064has logged in successfully.
868 1065
869If the callback returns something, it is sent back as if reply was being 1066If the callback returns something, it is sent back as if reply was being
870called. 1067called.
871 1068
1069=item cf::register_exticmd $name => \&callback($ns,$packet);
1070
1071Register a callback for execution when the client sends an (asynchronous)
1072exticmd packet. Exti commands are processed by the server as soon as they
1073are received, i.e. out of order w.r.t. other commands. The first argument
1074is a client socket. Exti commands can be received anytime, even before
1075log-in.
1076
1077If the callback returns something, it is sent back as if reply was being
1078called.
1079
872=cut 1080=cut
873 1081
874sub register_extcmd { 1082sub register_extcmd {
875 my ($name, $cb) = @_; 1083 my ($name, $cb) = @_;
876 1084
877 $EXTCMD{$name} = $cb; 1085 $EXTCMD{$name} = $cb;
1086}
1087
1088sub register_exticmd {
1089 my ($name, $cb) = @_;
1090
1091 $EXTICMD{$name} = $cb;
878} 1092}
879 1093
880cf::player->attach ( 1094cf::player->attach (
881 on_command => sub { 1095 on_command => sub {
882 my ($pl, $name, $params) = @_; 1096 my ($pl, $name, $params) = @_;
… …
891 cf::override; 1105 cf::override;
892 }, 1106 },
893 on_extcmd => sub { 1107 on_extcmd => sub {
894 my ($pl, $buf) = @_; 1108 my ($pl, $buf) = @_;
895 1109
896 my $msg = eval { from_json $buf }; 1110 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
897 1111
898 if (ref $msg) { 1112 if (ref $msg) {
899 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1113 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
900 if (my %reply = $cb->($pl, $msg)) { 1114 if (my %reply = $cb->($pl, $msg)) {
901 $pl->ext_reply ($msg->{msgid}, %reply); 1115 $pl->ext_reply ($msg->{msgid}, %reply);
… …
907 1121
908 cf::override; 1122 cf::override;
909 }, 1123 },
910); 1124);
911 1125
912sub load_extension {
913 my ($path) = @_;
914
915 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
916 my $base = $1;
917 my $pkg = $1;
918 $pkg =~ s/[^[:word:]]/_/g;
919 $pkg = "ext::$pkg";
920
921 warn "... loading '$path' into '$pkg'\n";
922
923 open my $fh, "<:utf8", $path
924 or die "$path: $!";
925
926 my $source =
927 "package $pkg; use strict; use utf8;\n"
928 . "#line 1 \"$path\"\n{\n"
929 . (do { local $/; <$fh> })
930 . "\n};\n1";
931
932 unless (eval $source) {
933 my $msg = $@ ? "$path: $@\n"
934 : "extension disabled.\n";
935 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
936 warn $@;
937 warn "mandatory extension failed to load, exiting.\n";
938 exit 1;
939 }
940 die $@;
941 }
942
943 push @EXTS, $pkg;
944}
945
946sub load_extensions { 1126sub load_extensions {
1127 cf::sync_job {
1128 my %todo;
1129
947 for my $ext (<$LIBDIR/*.ext>) { 1130 for my $path (<$LIBDIR/*.ext>) {
948 next unless -r $ext; 1131 next unless -r $path;
949 eval { 1132
950 load_extension $ext; 1133 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1134 my $base = $1;
1135 my $pkg = $1;
1136 $pkg =~ s/[^[:word:]]/_/g;
1137 $pkg = "ext::$pkg";
1138
1139 open my $fh, "<:utf8", $path
1140 or die "$path: $!";
1141
1142 my $source = do { local $/; <$fh> };
1143
1144 my %ext = (
1145 path => $path,
1146 base => $base,
1147 pkg => $pkg,
1148 );
1149
1150 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1151 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1152
1153 $ext{source} =
1154 "package $pkg; use strict; use utf8;\n"
1155 . "#line 1 \"$path\"\n{\n"
1156 . $source
1157 . "\n};\n1";
1158
1159 $todo{$base} = \%ext;
1160 }
1161
1162 my %done;
1163 while (%todo) {
1164 my $progress;
1165
1166 while (my ($k, $v) = each %todo) {
1167 for (split /,\s*/, $v->{meta}{depends}) {
1168 goto skip
1169 unless exists $done{$_};
1170 }
1171
1172 warn "... loading '$k' into '$v->{pkg}'\n";
1173
1174 unless (eval $v->{source}) {
1175 my $msg = $@ ? "$v->{path}: $@\n"
1176 : "$v->{base}: extension inactive.\n";
1177
1178 if (exists $v->{meta}{mandatory}) {
1179 warn $msg;
1180 warn "mandatory extension failed to load, exiting.\n";
1181 exit 1;
1182 }
1183
1184 warn $msg;
1185 }
1186
1187 $done{$k} = delete $todo{$k};
1188 push @EXTS, $v->{pkg};
1189 $progress = 1;
951 1 1190 }
952 } or warn "$ext not loaded: $@"; 1191
1192 skip:
1193 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1194 unless $progress;
1195 }
953 } 1196 };
954} 1197}
955 1198
956############################################################################# 1199#############################################################################
1200
1201=back
957 1202
958=head2 CORE EXTENSIONS 1203=head2 CORE EXTENSIONS
959 1204
960Functions and methods that extend core crossfire objects. 1205Functions and methods that extend core crossfire objects.
961 1206
… …
1149 } 1394 }
1150 1395
1151 \@paths 1396 \@paths
1152} 1397}
1153 1398
1399=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1400
1401Expand crossfire pod fragments into protocol xml.
1402
1403=cut
1404
1405sub expand_cfpod {
1406 ((my $self), (local $_)) = @_;
1407
1408 # escape & and <
1409 s/&/&amp;/g;
1410 s/(?<![BIUGH])</&lt;/g;
1411
1412 # this is buggy, it needs to properly take care of nested <'s
1413
1414 1 while
1415 # replace B<>, I<>, U<> etc.
1416 s/B<([^\>]*)>/<b>$1<\/b>/
1417 || s/I<([^\>]*)>/<i>$1<\/i>/
1418 || s/U<([^\>]*)>/<u>$1<\/u>/
1419 # replace G<male|female> tags
1420 || s{G<([^>|]*)\|([^>]*)>}{
1421 $self->gender ? $2 : $1
1422 }ge
1423 # replace H<hint text>
1424 || s{H<([^\>]*)>}
1425 {
1426 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1427 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1428 "")
1429 [$self->{hintmode}]
1430 }ge;
1431
1432 # create single paragraphs (very hackish)
1433 s/(?<=\S)\n(?=\w)/ /g;
1434
1435 # compress some whitespace
1436 s/\s+\n/\n/g; # ws line-ends
1437 s/\n\n+/\n/g; # double lines
1438 s/^\n+//; # beginning lines
1439 s/\n+$//; # ending lines
1440
1441 $_
1442}
1443
1444sub hintmode {
1445 $_[0]{hintmode} = $_[1] if @_ > 1;
1446 $_[0]{hintmode}
1447}
1448
1154=item $player->ext_reply ($msgid, %msg) 1449=item $player->ext_reply ($msgid, %msg)
1155 1450
1156Sends an ext reply to the player. 1451Sends an ext reply to the player.
1157 1452
1158=cut 1453=cut
1159 1454
1160sub ext_reply($$%) { 1455sub ext_reply($$%) {
1161 my ($self, $id, %msg) = @_; 1456 my ($self, $id, %msg) = @_;
1162 1457
1163 $msg{msgid} = $id; 1458 $msg{msgid} = $id;
1164 1459 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1165 $self->send ("ext " . cf::to_json \%msg);
1166} 1460}
1167 1461
1168=item $player->ext_event ($type, %msg) 1462=item $player->ext_event ($type, %msg)
1169 1463
1170Sends an ext event to the client. 1464Sends an ext event to the client.
… …
1185 1479
1186package cf::region; 1480package cf::region;
1187 1481
1188=item cf::region::find_by_path $path 1482=item cf::region::find_by_path $path
1189 1483
1190Tries to decuce the probable region for a map knowing only its path. 1484Tries to decuce the likely region for a map knowing only its path.
1191 1485
1192=cut 1486=cut
1193 1487
1194sub find_by_path($) { 1488sub find_by_path($) {
1195 my ($path) = @_; 1489 my ($path) = @_;
… …
1269 my ($self, $merge) = @_; 1563 my ($self, $merge) = @_;
1270 1564
1271 # we have to keep some variables in memory intact 1565 # we have to keep some variables in memory intact
1272 local $self->{path}; 1566 local $self->{path};
1273 local $self->{load_path}; 1567 local $self->{load_path};
1274 local $self->{deny_save};
1275 local $self->{deny_reset};
1276 1568
1277 $self->SUPER::thawer_merge ($merge); 1569 $self->SUPER::thawer_merge ($merge);
1278} 1570}
1279 1571
1280sub normalise { 1572sub normalise {
… …
1380 1672
1381 $_->change_map_light ($change) 1673 $_->change_map_light ($change)
1382 for grep $_->outdoor, values %cf::MAP; 1674 for grep $_->outdoor, values %cf::MAP;
1383} 1675}
1384 1676
1677sub decay_objects {
1678 my ($self) = @_;
1679
1680 return if $self->{deny_reset};
1681
1682 $self->do_decay_objects;
1683}
1684
1385sub unlink_save { 1685sub unlink_save {
1386 my ($self) = @_; 1686 my ($self) = @_;
1387 1687
1388 utf8::encode (my $save = $self->save_path); 1688 utf8::encode (my $save = $self->save_path);
1389 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1689 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1445 $self->load_header_orig 1745 $self->load_header_orig
1446 or return; 1746 or return;
1447 $self->prepare_orig; 1747 $self->prepare_orig;
1448 } 1748 }
1449 1749
1750 $self->{deny_reset} = 1
1751 if $self->no_reset;
1752
1450 $self->default_region (cf::region::find_by_path $self->{path}) 1753 $self->default_region (cf::region::find_by_path $self->{path})
1451 unless $self->default_region; 1754 unless $self->default_region;
1452 1755
1453 1 1756 1
1454} 1757}
… …
1469 $map->{last_save} = $cf::RUNTIME; 1772 $map->{last_save} = $cf::RUNTIME;
1470 1773
1471 $map->load_header 1774 $map->load_header
1472 or return; 1775 or return;
1473 1776
1474 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1777 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1475 # doing this can freeze the server in a sync job, obviously 1778 # doing this can freeze the server in a sync job, obviously
1476 #$cf::WAIT_FOR_TICK->wait; 1779 #$cf::WAIT_FOR_TICK->wait;
1477 $map->reset; 1780 $map->reset;
1478 undef $guard; 1781 undef $guard;
1479 return find $path; 1782 return find $path;
… …
1546 my ($self, $ob) = @_; 1849 my ($self, $ob) = @_;
1547 1850
1548 return find "~" . $ob->name . "/" . $self->{path} 1851 return find "~" . $ob->name . "/" . $self->{path}
1549 if $self->per_player; 1852 if $self->per_player;
1550 1853
1854# return find "?party/" . $ob->name . "/" . $self->{path}
1855# if $self->per_party;
1856
1551 $self 1857 $self
1552} 1858}
1553 1859
1554# find and load all maps in the 3x3 area around a map 1860# find and load all maps in the 3x3 area around a map
1555sub load_diag { 1861sub load_diag {
… …
1665 1971
1666sub reset_at { 1972sub reset_at {
1667 my ($self) = @_; 1973 my ($self) = @_;
1668 1974
1669 # TODO: safety, remove and allow resettable per-player maps 1975 # TODO: safety, remove and allow resettable per-player maps
1670 return 1e99 if $self->isa ("ext::map_per_player");#d#
1671 return 1e99 if $self->{deny_reset}; 1976 return 1e99 if $self->{deny_reset};
1672 1977
1673 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1978 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1674 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1979 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1675 1980
… …
1686 my ($self) = @_; 1991 my ($self) = @_;
1687 1992
1688 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1993 my $lock = cf::lock_acquire "map_data:$self->{path}";
1689 1994
1690 return if $self->players; 1995 return if $self->players;
1691 return if $self->isa ("ext::map_per_player");#d#
1692 1996
1693 warn "resetting map ", $self->path;#d# 1997 warn "resetting map ", $self->path;
1694 1998
1695 $self->in_memory (cf::MAP_SWAPPED); 1999 $self->in_memory (cf::MAP_SWAPPED);
1696 2000
1697 # need to save uniques path 2001 # need to save uniques path
1698 unless ($self->{deny_save}) { 2002 unless ($self->{deny_save}) {
… …
1730 $cf::MAP{$self->path} = $self; 2034 $cf::MAP{$self->path} = $self;
1731 2035
1732 $self->reset; # polite request, might not happen 2036 $self->reset; # polite request, might not happen
1733} 2037}
1734 2038
2039=item $maps = cf::map::tmp_maps
2040
2041Returns an arrayref with all map paths of currently instantiated and saved
2042maps. May block.
2043
2044=cut
2045
2046sub tmp_maps() {
2047 [
2048 map {
2049 utf8::decode $_;
2050 /\.map$/
2051 ? normalise $_
2052 : ()
2053 } @{ aio_readdir $TMPDIR or [] }
2054 ]
2055}
2056
2057=item $maps = cf::map::random_maps
2058
2059Returns an arrayref with all map paths of currently instantiated and saved
2060random maps. May block.
2061
2062=cut
2063
2064sub random_maps() {
2065 [
2066 map {
2067 utf8::decode $_;
2068 /\.map$/
2069 ? normalise "?random/$_"
2070 : ()
2071 } @{ aio_readdir $RANDOMDIR or [] }
2072 ]
2073}
2074
1735=item cf::map::unique_maps 2075=item cf::map::unique_maps
1736 2076
1737Returns an arrayref of paths of all shared maps that have 2077Returns an arrayref of paths of all shared maps that have
1738instantiated unique items. May block. 2078instantiated unique items. May block.
1739 2079
1740=cut 2080=cut
1741 2081
1742sub unique_maps() { 2082sub unique_maps() {
1743 my $files = aio_readdir $UNIQUEDIR 2083 [
1744 or return; 2084 map {
1745
1746 my @paths;
1747
1748 for (@$files) {
1749 utf8::decode $_; 2085 utf8::decode $_;
1750 next if /\.pst$/; 2086 /\.map$/
1751 next unless /^$PATH_SEP/o; 2087 ? normalise $_
1752 2088 : ()
1753 push @paths, cf::map::normalise $_; 2089 } @{ aio_readdir $UNIQUEDIR or [] }
1754 } 2090 ]
1755
1756 \@paths
1757} 2091}
1758 2092
1759package cf; 2093package cf;
1760 2094
1761=back 2095=back
… …
1807 2141
1808 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2142 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1809 2143
1810 if ($self->{record_replies}) { 2144 if ($self->{record_replies}) {
1811 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2145 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2146
1812 } else { 2147 } else {
2148 my $pl = $self->contr;
2149
2150 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151 my $diag = $pl->{npc_dialog};
2152 $diag->{pl}->ext_reply (
2153 $diag->{id},
2154 msgtype => "reply",
2155 msg => $diag->{pl}->expand_cfpod ($msg),
2156 add_topics => []
2157 );
2158
2159 } else {
1813 $msg = $npc->name . " says: $msg" if $npc; 2160 $msg = $npc->name . " says: $msg" if $npc;
1814 $self->message ($msg, $flags); 2161 $self->message ($msg, $flags);
2162 }
1815 } 2163 }
1816} 2164}
1817 2165
1818=item $player_object->may ("access") 2166=item $player_object->may ("access")
1819 2167
… …
1862} 2210}
1863 2211
1864sub cf::object::player::enter_link { 2212sub cf::object::player::enter_link {
1865 my ($self) = @_; 2213 my ($self) = @_;
1866 2214
1867 $self->activate_recursive; 2215 $self->deactivate_recursive;
1868 2216
1869 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2217 return if UNIVERSAL::isa $self->map, "ext::map_link";
1870 2218
1871 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2219 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1872 if $self->map; 2220 if $self->map && $self->map->{path} ne "{link}";
1873 2221
1874 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2222 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1875} 2223}
1876 2224
1877sub cf::object::player::leave_link { 2225sub cf::object::player::leave_link {
1878 my ($self, $map, $x, $y) = @_; 2226 my ($self, $map, $x, $y) = @_;
2227
2228 return unless $self->contr->active;
1879 2229
1880 my $link_pos = delete $self->{_link_pos}; 2230 my $link_pos = delete $self->{_link_pos};
1881 2231
1882 unless ($map) { 2232 unless ($map) {
1883 # restore original map position 2233 # restore original map position
… …
1906 2256
1907 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2257 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1908 $self->enter_map ($map, $x, $y); 2258 $self->enter_map ($map, $x, $y);
1909} 2259}
1910 2260
1911cf::player->attach (
1912 on_logout => sub {
1913 my ($pl) = @_;
1914
1915 # abort map switching before logout
1916 if ($pl->ob->{_link_pos}) {
1917 cf::sync_job {
1918 $pl->ob->leave_link
1919 };
1920 }
1921 },
1922 on_login => sub {
1923 my ($pl) = @_;
1924
1925 # try to abort aborted map switching on player login :)
1926 # should happen only on crashes
1927 if ($pl->ob->{_link_pos}) {
1928 $pl->ob->enter_link;
1929 (async {
1930 $pl->ob->reply (undef,
1931 "There was an internal problem at your last logout, "
1932 . "the server will try to bring you to your intended destination in a second.",
1933 cf::NDI_RED);
1934 # we need this sleep as the login has a concurrent enter_exit running
1935 # and this sleep increases chances of the player not ending up in scorn
1936 Coro::Timer::sleep 1;
1937 $pl->ob->leave_link;
1938 })->prio (2);
1939 }
1940 },
1941);
1942
1943=item $player_object->goto ($path, $x, $y) 2261=item $player_object->goto ($path, $x, $y[, $check->($map)])
1944 2262
2263Moves the player to the given map-path and coordinates by first freezing
2264her, loading and preparing them map, calling the provided $check callback
2265that has to return the map if sucecssful, and then unfreezes the player on
2266the new (success) or old (failed) map position.
2267
1945=cut 2268=cut
2269
2270our $GOTOGEN;
1946 2271
1947sub cf::object::player::goto { 2272sub cf::object::player::goto {
1948 my ($self, $path, $x, $y) = @_; 2273 my ($self, $path, $x, $y, $check) = @_;
2274
2275 # do generation counting so two concurrent goto's will be executed in-order
2276 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1949 2277
1950 $self->enter_link; 2278 $self->enter_link;
1951 2279
1952 (async { 2280 (async {
1953 my $map = eval { 2281 my $map = eval {
1954 my $map = cf::map::find $path; 2282 my $map = cf::map::find $path;
2283
2284 if ($map) {
1955 $map = $map->customise_for ($self) if $map; 2285 $map = $map->customise_for ($self);
2286 $map = $check->($map) if $check && $map;
2287 } else {
2288 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2289 }
2290
1956 $map 2291 $map
2292 };
2293
2294 if ($@) {
2295 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2296 LOG llevError | logBacktrace, Carp::longmess $@;
1957 } or 2297 }
1958 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1959 2298
2299 if ($gen == $self->{_goto_generation}) {
2300 delete $self->{_goto_generation};
1960 $self->leave_link ($map, $x, $y); 2301 $self->leave_link ($map, $x, $y);
2302 }
1961 })->prio (1); 2303 })->prio (1);
1962} 2304}
1963 2305
1964=item $player_object->enter_exit ($exit_object) 2306=item $player_object->enter_exit ($exit_object)
1965 2307
… …
2034 my $hp = $exit->stats->hp; 2376 my $hp = $exit->stats->hp;
2035 my $sp = $exit->stats->sp; 2377 my $sp = $exit->stats->sp;
2036 2378
2037 $self->enter_link; 2379 $self->enter_link;
2038 2380
2381 # if exit is damned, update players death & WoR home-position
2382 $self->contr->savebed ($slaying, $hp, $sp)
2383 if $exit->flag (FLAG_DAMNED);
2384
2039 (async { 2385 (async {
2040 $self->deactivate_recursive; # just to be sure 2386 $self->deactivate_recursive; # just to be sure
2041 unless (eval { 2387 unless (eval {
2042 $self->goto ($slaying, $hp, $sp); 2388 $self->goto ($slaying, $hp, $sp);
2043 2389
… …
2070 2416
2071 utf8::encode $text; 2417 utf8::encode $text;
2072 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2418 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2073} 2419}
2074 2420
2421=item $client->send_msg ($color, $type, $msg, [extra...])
2422
2423Send a drawinfo or msg packet to the client, formatting the msg for the
2424client if neccessary. C<$type> should be a string identifying the type of
2425the message, with C<log> being the default. If C<$color> is negative, suppress
2426the message unless the client supports the msg packet.
2427
2428=cut
2429
2430sub cf::client::send_msg {
2431 my ($self, $color, $type, $msg, @extra) = @_;
2432
2433 $msg = $self->pl->expand_cfpod ($msg);
2434
2435 return unless @extra || length $msg;
2436
2437 if ($self->can_msg) {
2438 $self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));
2439 } else {
2440 # replace some tags by gcfclient-compatible ones
2441 for ($msg) {
2442 1 while
2443 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2444 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2445 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2446 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2447 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2448 }
2449
2450 if ($color >= 0) {
2451 if (0 && $msg =~ /\[/) {
2452 $self->send_packet ("drawextinfo $color 4 0 $msg")
2453 } else {
2454 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2455 $self->send_packet ("drawinfo $color $msg")
2456 }
2457 }
2458 }
2459}
2460
2075=item $client->ext_event ($type, %msg) 2461=item $client->ext_event ($type, %msg)
2076 2462
2077Sends an exti event to the client. 2463Sends an ext event to the client.
2078 2464
2079=cut 2465=cut
2080 2466
2081sub cf::client::ext_event($$%) { 2467sub cf::client::ext_event($$%) {
2082 my ($self, $type, %msg) = @_; 2468 my ($self, $type, %msg) = @_;
2083 2469
2084 $msg{msgtype} = "event_$type"; 2470 $msg{msgtype} = "event_$type";
2085 $self->send_packet ("ext " . cf::to_json \%msg); 2471 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2086} 2472}
2087 2473
2088=item $success = $client->query ($flags, "text", \&cb) 2474=item $success = $client->query ($flags, "text", \&cb)
2089 2475
2090Queues a query to the client, calling the given callback with 2476Queues a query to the client, calling the given callback with
2091the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2477the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2092C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2478C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2093 2479
2094Queries can fail, so check the return code. Or don't, as queries will become 2480Queries can fail, so check the return code. Or don't, as queries will
2095reliable at some point in the future. 2481become reliable at some point in the future.
2096 2482
2097=cut 2483=cut
2098 2484
2099sub cf::client::query { 2485sub cf::client::query {
2100 my ($self, $flags, $text, $cb) = @_; 2486 my ($self, $flags, $text, $cb) = @_;
… …
2108 utf8::encode $text; 2494 utf8::encode $text;
2109 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2495 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2110 2496
2111 $self->send_packet ($self->{query_queue}[0][0]) 2497 $self->send_packet ($self->{query_queue}[0][0])
2112 if @{ $self->{query_queue} } == 1; 2498 if @{ $self->{query_queue} } == 1;
2499
2500 1
2113} 2501}
2114 2502
2115cf::client->attach ( 2503cf::client->attach (
2504 on_connect => sub {
2505 my ($ns) = @_;
2506
2507 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2508 },
2116 on_reply => sub { 2509 on_reply => sub {
2117 my ($ns, $msg) = @_; 2510 my ($ns, $msg) = @_;
2118 2511
2119 # this weird shuffling is so that direct followup queries 2512 # this weird shuffling is so that direct followup queries
2120 # get handled first 2513 # get handled first
… …
2132 } else { 2525 } else {
2133 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2526 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2134 } 2527 }
2135 } 2528 }
2136 }, 2529 },
2530 on_exticmd => sub {
2531 my ($ns, $buf) = @_;
2532
2533 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2534
2535 if (ref $msg) {
2536 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2537 if (my %reply = $cb->($ns, $msg)) {
2538 $reply{msgid} = $msg->{msgid};
2539 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2540 }
2541 }
2542 } else {
2543 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2544 }
2545
2546 cf::override;
2547 },
2137); 2548);
2138 2549
2139=item $client->async (\&cb) 2550=item $client->async (\&cb)
2140 2551
2141Create a new coroutine, running the specified callback. The coroutine will 2552Create a new coroutine, running the specified callback. The coroutine will
… …
2190 2601
2191=pod 2602=pod
2192 2603
2193The following functions and methods are available within a safe environment: 2604The following functions and methods are available within a safe environment:
2194 2605
2195 cf::object contr pay_amount pay_player map 2606 cf::object
2607 contr pay_amount pay_player map x y force_find force_add
2608 insert remove
2609
2196 cf::object::player player 2610 cf::object::player
2197 cf::player peaceful 2611 player
2198 cf::map trigger 2612
2613 cf::player
2614 peaceful
2615
2616 cf::map
2617 trigger
2199 2618
2200=cut 2619=cut
2201 2620
2202for ( 2621for (
2203 ["cf::object" => qw(contr pay_amount pay_player map)], 2622 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2623 insert remove)],
2204 ["cf::object::player" => qw(player)], 2624 ["cf::object::player" => qw(player)],
2205 ["cf::player" => qw(peaceful)], 2625 ["cf::player" => qw(peaceful)],
2206 ["cf::map" => qw(trigger)], 2626 ["cf::map" => qw(trigger)],
2207) { 2627) {
2208 no strict 'refs'; 2628 no strict 'refs';
… …
2279=back 2699=back
2280 2700
2281=cut 2701=cut
2282 2702
2283############################################################################# 2703#############################################################################
2284
2285=head2 EXTENSION DATABASE SUPPORT
2286
2287Crossfire maintains a very simple database for extension use. It can
2288currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2289convert to/from binary).
2290
2291The parameter C<$family> should best start with the name of the extension
2292using it, it should be unique.
2293
2294=over 4
2295
2296=item $value = cf::db_get $family => $key
2297
2298Returns a single value from the database.
2299
2300=item cf::db_put $family => $key => $value
2301
2302Stores the given C<$value> in the family.
2303
2304=cut
2305
2306our $DB;
2307
2308sub db_init {
2309 unless ($DB) {
2310 $DB = BDB::db_create $DB_ENV;
2311
2312 cf::sync_job {
2313 eval {
2314 $DB->set_flags (BDB::CHKSUM);
2315
2316 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2317 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2318 cf::cleanup "db_open(db): $!" if $!;
2319 };
2320 cf::cleanup "db_open(db): $@" if $@;
2321 };
2322 }
2323}
2324
2325sub db_get($$) {
2326 my $key = "$_[0]/$_[1]";
2327
2328 cf::sync_job {
2329 BDB::db_get $DB, undef, $key, my $data;
2330
2331 $! ? ()
2332 : $data
2333 }
2334}
2335
2336sub db_put($$$) {
2337 BDB::dbreq_pri 4;
2338 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2339}
2340
2341=item cf::cache $id => [$paths...], $processversion => $process
2342
2343Generic caching function that returns the value of the resource $id,
2344caching and regenerating as required.
2345
2346This function can block.
2347
2348=cut
2349
2350sub cache {
2351 my ($id, $src, $processversion, $process) = @_;
2352
2353 my $meta =
2354 join "\x00",
2355 $processversion,
2356 map {
2357 aio_stat $_
2358 and Carp::croak "$_: $!";
2359
2360 ($_, (stat _)[7,9])
2361 } @$src;
2362
2363 my $dbmeta = db_get cache => "$id/meta";
2364 if ($dbmeta ne $meta) {
2365 # changed, we may need to process
2366
2367 my @data;
2368 my $md5;
2369
2370 for (0 .. $#$src) {
2371 0 <= aio_load $src->[$_], $data[$_]
2372 or Carp::croak "$src->[$_]: $!";
2373 }
2374
2375 # if processing is expensive, check
2376 # checksum first
2377 if (1) {
2378 $md5 =
2379 join "\x00",
2380 $processversion,
2381 map {
2382 Coro::cede;
2383 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2384 } 0.. $#$src;
2385
2386
2387 my $dbmd5 = db_get cache => "$id/md5";
2388 if ($dbmd5 eq $md5) {
2389 db_put cache => "$id/meta", $meta;
2390
2391 return db_get cache => "$id/data";
2392 }
2393 }
2394
2395 my $t1 = Time::HiRes::time;
2396 my $data = $process->(\@data);
2397 my $t2 = Time::HiRes::time;
2398
2399 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2400
2401 db_put cache => "$id/data", $data;
2402 db_put cache => "$id/md5" , $md5;
2403 db_put cache => "$id/meta", $meta;
2404
2405 return $data;
2406 }
2407
2408 db_get cache => "$id/data"
2409}
2410
2411=item fork_call { }, $args
2412
2413Executes the given code block with the given arguments in a seperate
2414process, returning the results. Everything must be serialisable with
2415Coro::Storable. May, of course, block. Note that the executed sub may
2416never block itself or use any form of Event handling.
2417
2418=cut
2419
2420sub fork_call(&@) {
2421 my ($cb, @args) = @_;
2422
2423# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2424# or die "socketpair: $!";
2425 pipe my $fh1, my $fh2
2426 or die "pipe: $!";
2427
2428 if (my $pid = fork) {
2429 close $fh2;
2430
2431 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2432 $res = Coro::Storable::thaw $res;
2433
2434 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2435
2436 die $$res unless "ARRAY" eq ref $res;
2437
2438 return wantarray ? @$res : $res->[-1];
2439 } else {
2440 local $SIG{__WARN__};
2441 eval {
2442 local $SIG{__DIE__};
2443 close $fh1;
2444
2445 my @res = eval { $cb->(@args) };
2446 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2447 };
2448
2449 warn $@ if $@;
2450 _exit 0;
2451 }
2452}
2453
2454
2455
2456#############################################################################
2457# the server's init and main functions 2704# the server's init and main functions
2458 2705
2459sub load_facedata($) { 2706sub load_facedata($) {
2460 my ($path) = @_; 2707 my ($path) = @_;
2461 2708
… …
2473 { 2720 {
2474 my $faces = $facedata->{faceinfo}; 2721 my $faces = $facedata->{faceinfo};
2475 2722
2476 while (my ($face, $info) = each %$faces) { 2723 while (my ($face, $info) = each %$faces) {
2477 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2724 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2478 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2725 cf::face::set_visibility $idx, $info->{visibility};
2726 cf::face::set_magicmap $idx, $info->{magicmap};
2479 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2727 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2480 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2728 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2481 Coro::cede; 2729
2730 cf::cede_to_tick;
2482 } 2731 }
2483 2732
2484 while (my ($face, $info) = each %$faces) { 2733 while (my ($face, $info) = each %$faces) {
2485 next unless $info->{smooth}; 2734 next unless $info->{smooth};
2486 my $idx = cf::face::find $face 2735 my $idx = cf::face::find $face
2487 or next; 2736 or next;
2488 if (my $smooth = cf::face::find $info->{smooth}) { 2737 if (my $smooth = cf::face::find $info->{smooth}) {
2738 cf::face::set_smooth $idx, $smooth;
2489 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2739 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2490 } else { 2740 } else {
2491 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2741 warn "smooth face '$info->{smooth}' not found for face '$face'";
2492 } 2742 }
2493 Coro::cede; 2743
2744 cf::cede_to_tick;
2494 } 2745 }
2495 } 2746 }
2496 2747
2497 { 2748 {
2498 my $anims = $facedata->{animinfo}; 2749 my $anims = $facedata->{animinfo};
2499 2750
2500 while (my ($anim, $info) = each %$anims) { 2751 while (my ($anim, $info) = each %$anims) {
2501 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2752 cf::anim::set $anim, $info->{frames}, $info->{facings};
2502 Coro::cede; 2753 cf::cede_to_tick;
2503 } 2754 }
2504 2755
2505 cf::anim::invalidate_all; # d'oh 2756 cf::anim::invalidate_all; # d'oh
2757 }
2758
2759 {
2760 # TODO: for gcfclient pleasure, we should give resources
2761 # that gcfclient doesn't grok a >10000 face index.
2762 my $res = $facedata->{resource};
2763 my $enc = JSON::XS->new->utf8->canonical;
2764
2765 while (my ($name, $info) = each %$res) {
2766 my $meta = $enc->encode ({
2767 name => $name,
2768 type => $info->{type},
2769 copyright => $info->{copyright}, #TODO#
2770 });
2771 my $data = pack "(w/a*)*", $meta, $info->{data};
2772 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2773
2774 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2775 cf::face::set_type $idx, 1;
2776 cf::face::set_data $idx, 0, $data, $chk;
2777
2778 cf::cede_to_tick;
2779 }
2506 } 2780 }
2507 2781
2508 1 2782 1
2509} 2783}
2510 2784
… …
2519} 2793}
2520 2794
2521sub reload_archetypes { 2795sub reload_archetypes {
2522 load_resource_file "$DATADIR/archetypes" 2796 load_resource_file "$DATADIR/archetypes"
2523 or die "unable to load archetypes\n"; 2797 or die "unable to load archetypes\n";
2798 #d# NEED to laod twice to resolve forward references
2799 # this really needs to be done in an extra post-pass
2800 # (which needs to be synchronous, so solve it differently)
2801 load_resource_file "$DATADIR/archetypes"
2802 or die "unable to load archetypes\n";
2524} 2803}
2525 2804
2526sub reload_treasures { 2805sub reload_treasures {
2527 load_resource_file "$DATADIR/treasures" 2806 load_resource_file "$DATADIR/treasures"
2528 or die "unable to load treasurelists\n"; 2807 or die "unable to load treasurelists\n";
… …
2531sub reload_resources { 2810sub reload_resources {
2532 warn "reloading resource files...\n"; 2811 warn "reloading resource files...\n";
2533 2812
2534 reload_regions; 2813 reload_regions;
2535 reload_facedata; 2814 reload_facedata;
2815 #reload_archetypes;#d#
2536 reload_archetypes; 2816 reload_archetypes;
2537 reload_treasures; 2817 reload_treasures;
2538 2818
2539 warn "finished reloading resource files\n"; 2819 warn "finished reloading resource files\n";
2540} 2820}
… …
2597 }, 2877 },
2598 ); 2878 );
2599 } 2879 }
2600} 2880}
2601 2881
2882sub write_runtime {
2883 my $runtime = "$LOCALDIR/runtime";
2884
2885 # first touch the runtime file to show we are still running:
2886 # the fsync below can take a very very long time.
2887
2888 IO::AIO::aio_utime $runtime, undef, undef;
2889
2890 my $guard = cf::lock_acquire "write_runtime";
2891
2892 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2893 or return;
2894
2895 my $value = $cf::RUNTIME + 90 + 10;
2896 # 10 is the runtime save interval, for a monotonic clock
2897 # 60 allows for the watchdog to kill the server.
2898
2899 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2900 and return;
2901
2902 # always fsync - this file is important
2903 aio_fsync $fh
2904 and return;
2905
2906 # touch it again to show we are up-to-date
2907 aio_utime $fh, undef, undef;
2908
2909 close $fh
2910 or return;
2911
2912 aio_rename "$runtime~", $runtime
2913 and return;
2914
2915 warn "runtime file written.\n";
2916
2917 1
2918}
2919
2602sub emergency_save() { 2920sub emergency_save() {
2603 my $freeze_guard = cf::freeze_mainloop; 2921 my $freeze_guard = cf::freeze_mainloop;
2604 2922
2605 warn "enter emergency perl save\n"; 2923 warn "enter emergency perl save\n";
2606 2924
… …
2681 %EXT_CORO = (); 2999 %EXT_CORO = ();
2682 3000
2683 warn "removing commands"; 3001 warn "removing commands";
2684 %COMMAND = (); 3002 %COMMAND = ();
2685 3003
2686 warn "removing ext commands"; 3004 warn "removing ext/exti commands";
2687 %EXTCMD = (); 3005 %EXTCMD = ();
3006 %EXTICMD = ();
2688 3007
2689 warn "unloading/nuking all extensions"; 3008 warn "unloading/nuking all extensions";
2690 for my $pkg (@EXTS) { 3009 for my $pkg (@EXTS) {
2691 warn "... unloading $pkg"; 3010 warn "... unloading $pkg";
2692 3011
… …
2810 my $signal = new Coro::Signal; 3129 my $signal = new Coro::Signal;
2811 push @WAIT_FOR_TICK_BEGIN, $signal; 3130 push @WAIT_FOR_TICK_BEGIN, $signal;
2812 $signal->wait; 3131 $signal->wait;
2813} 3132}
2814 3133
3134 my $min = 1e6;#d#
3135 my $avg = 10;
2815$TICK_WATCHER = Event->timer ( 3136$TICK_WATCHER = Event->timer (
2816 reentrant => 0, 3137 reentrant => 0,
2817 parked => 1, 3138 parked => 1,
2818 prio => 0, 3139 prio => 0,
2819 at => $NEXT_TICK || $TICK, 3140 at => $NEXT_TICK || $TICK,
… …
2823 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3144 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2824 unless ++$bug_warning > 10; 3145 unless ++$bug_warning > 10;
2825 return; 3146 return;
2826 } 3147 }
2827 3148
2828 $NOW = Event::time; 3149 $NOW = $tick_start = Event::time;
2829 3150
2830 cf::server_tick; # one server iteration 3151 cf::server_tick; # one server iteration
3152
3153 0 && sync_job {#d#
3154 for(1..10) {
3155 my $t = Event::time;
3156 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3157 or die;
3158
3159 $map->width (50);
3160 $map->height (50);
3161 $map->alloc;
3162 $map->_load_objects ("/tmp/x.map", 1);
3163 my $t = Event::time - $t;
3164
3165 #next unless $t < 0.0013;#d#
3166 if ($t < $min) {
3167 $min = $t;
3168 }
3169 $avg = $avg * 0.99 + $t * 0.01;
3170 }
3171 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3172 exit 0;
3173 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3174 };
2831 3175
2832 $RUNTIME += $TICK; 3176 $RUNTIME += $TICK;
2833 $NEXT_TICK += $TICK; 3177 $NEXT_TICK += $TICK;
2834 3178
2835 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3179 if ($NOW >= $NEXT_RUNTIME_WRITE) {
… …
2841 } 3185 }
2842 3186
2843# my $AFTER = Event::time; 3187# my $AFTER = Event::time;
2844# warn $AFTER - $NOW;#d# 3188# warn $AFTER - $NOW;#d#
2845 3189
3190 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3191 $sig->send;
3192 }
3193 while (my $sig = shift @WAIT_FOR_TICK) {
3194 $sig->send;
3195 }
3196
3197 $NOW = Event::time;
3198
2846 # if we are delayed by four ticks or more, skip them all 3199 # if we are delayed by four ticks or more, skip them all
2847 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3200 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2848 3201
2849 $TICK_WATCHER->at ($NEXT_TICK); 3202 $TICK_WATCHER->at ($NEXT_TICK);
2850 $TICK_WATCHER->start; 3203 $TICK_WATCHER->start;
2851 3204
2852 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3205 $LOAD = ($NOW - $tick_start) / $TICK;
2853 $sig->send; 3206 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2854 }
2855 while (my $sig = shift @WAIT_FOR_TICK) {
2856 $sig->send;
2857 }
2858 3207
2859 _post_tick; 3208 _post_tick;
3209
3210
2860 }, 3211 },
2861); 3212);
2862 3213
2863{ 3214{
2864 BDB::max_poll_time $TICK * 0.1; 3215 BDB::max_poll_time $TICK * 0.1;
… …
2923 prio => 6, 3274 prio => 6,
2924 cb => \&IO::AIO::poll_cb, 3275 cb => \&IO::AIO::poll_cb,
2925 ); 3276 );
2926} 3277}
2927 3278
3279my $_log_backtrace;
3280
3281sub _log_backtrace {
3282 my ($msg, @addr) = @_;
3283
3284 $msg =~ s/\n//;
3285
3286 # limit the # of concurrent backtraces
3287 if ($_log_backtrace < 2) {
3288 ++$_log_backtrace;
3289 async {
3290 my @bt = fork_call {
3291 @addr = map { sprintf "%x", $_ } @addr;
3292 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3293 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3294 or die "addr2line: $!";
3295
3296 my @funcs;
3297 my @res = <$fh>;
3298 chomp for @res;
3299 while (@res) {
3300 my ($func, $line) = splice @res, 0, 2, ();
3301 push @funcs, "[$func] $line";
3302 }
3303
3304 @funcs
3305 };
3306
3307 LOG llevInfo, "[ABT] $msg\n";
3308 LOG llevInfo, "[ABT] $_\n" for @bt;
3309 --$_log_backtrace;
3310 };
3311 } else {
3312 LOG llevInfo, "[ABT] $msg\n";
3313 LOG llevInfo, "[ABT] [suppressed]\n";
3314 }
3315}
3316
2928# load additional modules 3317# load additional modules
2929use cf::pod; 3318use cf::pod;
2930 3319
2931END { cf::emergency_save } 3320END { cf::emergency_save }
2932 3321

Diff Legend

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