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.263 by root, Sat May 5 05:40:27 2007 UTC vs.
Revision 1.305 by root, Thu Jul 12 08:40:14 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 warn "starting to write runtime...\n";#d# 413=cut
377 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
378 or return;
379 414
380 my $value = $cf::RUNTIME + 90 + 10; 415sub _store_scalar {
381 # 10 is the runtime save interval, for a monotonic clock 416 open my $fh, ">", \my $buf
382 # 60 allows for the watchdog to kill the server. 417 or die "fork_call: cannot open fh-to-buf in child : $!";
383 418 Storable::store_fd $_[0], $fh;
384 (aio_write $fh, 0, (length $value), $value, 0) <= 0
385 and return;
386
387 # always fsync - this file is important
388 aio_fsync $fh
389 and return;
390
391 close $fh 419 close $fh;
392 or return;
393 420
394 aio_rename "$runtime~", $runtime 421 $buf
395 and return; 422}
396 423
397 warn "... done writing runtime.\n";#d# 424sub fork_call(&@) {
425 my ($cb, @args) = @_;
398 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;
399 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"
400} 582}
401 583
402=item cf::datalog type => key => value, ... 584=item cf::datalog type => key => value, ...
403 585
404Log 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.
… …
422attach callbacks/event handlers (a collection of which is called an "attachment") 604attach callbacks/event handlers (a collection of which is called an "attachment")
423to it. All such attachable objects support the following methods. 605to it. All such attachable objects support the following methods.
424 606
425In 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>
426C<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
427crossfire+). 609Crossfire TRT).
428 610
429=over 4 611=over 4
430 612
431=item $attachable->attach ($attachment, key => $value...) 613=item $attachable->attach ($attachment, key => $value...)
432 614
… …
595 $registry = $CB_TYPE[$object_type] ||= []; 777 $registry = $CB_TYPE[$object_type] ||= [];
596 778
597 } elsif ($type eq "subtype") { 779 } elsif ($type eq "subtype") {
598 defined $object_type or Carp::croak "subtype specified without type"; 780 defined $object_type or Carp::croak "subtype specified without type";
599 my $object_subtype = shift @arg; 781 my $object_subtype = shift @arg;
600 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 782 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
601 783
602 } elsif ($type eq "package") { 784 } elsif ($type eq "package") {
603 my $pkg = shift @arg; 785 my $pkg = shift @arg;
604 786
605 while (my ($name, $id) = each %cb_id) { 787 while (my ($name, $id) = each %cb_id) {
… …
634 _attach $registry, $klass, @attach; 816 _attach $registry, $klass, @attach;
635 } 817 }
636 818
637 $obj->{$name} = \%arg; 819 $obj->{$name} = \%arg;
638 } else { 820 } else {
639 warn "object uses attachment '$name' that is not available, postponing.\n"; 821 warn "object uses attachment '$name' which is not available, postponing.\n";
640 } 822 }
641 823
642 $obj->{_attachment}{$name} = undef; 824 $obj->{_attachment}{$name} = undef;
643} 825}
644 826
… …
646 if (ref $_[0]) { 828 if (ref $_[0]) {
647 _object_attach @_; 829 _object_attach @_;
648 } else { 830 } else {
649 _attach shift->_attach_registry, @_; 831 _attach shift->_attach_registry, @_;
650 } 832 }
833 _recalc_want;
651}; 834};
652 835
653# all those should be optimised 836# all those should be optimised
654sub cf::attachable::detach { 837sub cf::attachable::detach {
655 my ($obj, $name) = @_; 838 my ($obj, $name) = @_;
… …
658 delete $obj->{_attachment}{$name}; 841 delete $obj->{_attachment}{$name};
659 reattach ($obj); 842 reattach ($obj);
660 } else { 843 } else {
661 Carp::croak "cannot, currently, detach class attachments"; 844 Carp::croak "cannot, currently, detach class attachments";
662 } 845 }
846 _recalc_want;
663}; 847};
664 848
665sub cf::attachable::attached { 849sub cf::attachable::attached {
666 my ($obj, $name) = @_; 850 my ($obj, $name) = @_;
667 851
… …
840 or return; 1024 or return;
841 $av = eval { (Storable::thaw $av)->{objs} }; 1025 $av = eval { (Storable::thaw $av)->{objs} };
842 } 1026 }
843 1027
844 warn sprintf "loading %s (%d)\n", 1028 warn sprintf "loading %s (%d)\n",
845 $filename, length $data, scalar @{$av || []};#d# 1029 $filename, length $data, scalar @{$av || []};
846 return ($data, $av); 1030 return ($data, $av);
847} 1031}
1032
1033=head2 COMMAND CALLBACKS
1034
1035=over 4
1036
1037=cut
848 1038
849############################################################################# 1039#############################################################################
850# command handling &c 1040# command handling &c
851 1041
852=item cf::register_command $name => \&callback($ob,$args); 1042=item cf::register_command $name => \&callback($ob,$args);
… …
865 push @{ $COMMAND{$name} }, [$caller, $cb]; 1055 push @{ $COMMAND{$name} }, [$caller, $cb];
866} 1056}
867 1057
868=item cf::register_extcmd $name => \&callback($pl,$packet); 1058=item cf::register_extcmd $name => \&callback($pl,$packet);
869 1059
870Register 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.
871 1065
872If 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
873called. 1067called.
874 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
875=cut 1080=cut
876 1081
877sub register_extcmd { 1082sub register_extcmd {
878 my ($name, $cb) = @_; 1083 my ($name, $cb) = @_;
879 1084
880 $EXTCMD{$name} = $cb; 1085 $EXTCMD{$name} = $cb;
1086}
1087
1088sub register_exticmd {
1089 my ($name, $cb) = @_;
1090
1091 $EXTICMD{$name} = $cb;
881} 1092}
882 1093
883cf::player->attach ( 1094cf::player->attach (
884 on_command => sub { 1095 on_command => sub {
885 my ($pl, $name, $params) = @_; 1096 my ($pl, $name, $params) = @_;
… …
894 cf::override; 1105 cf::override;
895 }, 1106 },
896 on_extcmd => sub { 1107 on_extcmd => sub {
897 my ($pl, $buf) = @_; 1108 my ($pl, $buf) = @_;
898 1109
899 my $msg = eval { from_json $buf }; 1110 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
900 1111
901 if (ref $msg) { 1112 if (ref $msg) {
902 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1113 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
903 if (my %reply = $cb->($pl, $msg)) { 1114 if (my %reply = $cb->($pl, $msg)) {
904 $pl->ext_reply ($msg->{msgid}, %reply); 1115 $pl->ext_reply ($msg->{msgid}, %reply);
… …
910 1121
911 cf::override; 1122 cf::override;
912 }, 1123 },
913); 1124);
914 1125
915sub load_extension {
916 my ($path) = @_;
917
918 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
919 my $base = $1;
920 my $pkg = $1;
921 $pkg =~ s/[^[:word:]]/_/g;
922 $pkg = "ext::$pkg";
923
924 warn "... loading '$path' into '$pkg'\n";
925
926 open my $fh, "<:utf8", $path
927 or die "$path: $!";
928
929 my $source =
930 "package $pkg; use strict; use utf8;\n"
931 . "#line 1 \"$path\"\n{\n"
932 . (do { local $/; <$fh> })
933 . "\n};\n1";
934
935 unless (eval $source) {
936 my $msg = $@ ? "$path: $@\n"
937 : "extension disabled.\n";
938 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
939 warn $@;
940 warn "mandatory extension failed to load, exiting.\n";
941 exit 1;
942 }
943 die $@;
944 }
945
946 push @EXTS, $pkg;
947}
948
949sub load_extensions { 1126sub load_extensions {
1127 cf::sync_job {
1128 my %todo;
1129
950 for my $ext (<$LIBDIR/*.ext>) { 1130 for my $path (<$LIBDIR/*.ext>) {
951 next unless -r $ext; 1131 next unless -r $path;
952 eval { 1132
953 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;
954 1 1190 }
955 } or warn "$ext not loaded: $@"; 1191
1192 skip:
1193 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1194 unless $progress;
1195 }
956 } 1196 };
957} 1197}
958 1198
959############################################################################# 1199#############################################################################
1200
1201=back
960 1202
961=head2 CORE EXTENSIONS 1203=head2 CORE EXTENSIONS
962 1204
963Functions and methods that extend core crossfire objects. 1205Functions and methods that extend core crossfire objects.
964 1206
… …
1152 } 1394 }
1153 1395
1154 \@paths 1396 \@paths
1155} 1397}
1156 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
1157=item $player->ext_reply ($msgid, %msg) 1449=item $player->ext_reply ($msgid, %msg)
1158 1450
1159Sends an ext reply to the player. 1451Sends an ext reply to the player.
1160 1452
1161=cut 1453=cut
1162 1454
1163sub ext_reply($$%) { 1455sub ext_reply($$%) {
1164 my ($self, $id, %msg) = @_; 1456 my ($self, $id, %msg) = @_;
1165 1457
1166 $msg{msgid} = $id; 1458 $msg{msgid} = $id;
1167 1459 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1168 $self->send ("ext " . cf::to_json \%msg);
1169} 1460}
1170 1461
1171=item $player->ext_event ($type, %msg) 1462=item $player->ext_event ($type, %msg)
1172 1463
1173Sends an ext event to the client. 1464Sends an ext event to the client.
… …
1188 1479
1189package cf::region; 1480package cf::region;
1190 1481
1191=item cf::region::find_by_path $path 1482=item cf::region::find_by_path $path
1192 1483
1193Tries 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.
1194 1485
1195=cut 1486=cut
1196 1487
1197sub find_by_path($) { 1488sub find_by_path($) {
1198 my ($path) = @_; 1489 my ($path) = @_;
1199 1490
1200 my ($match, $specificity); 1491 my ($match, $specificity);
1201 1492
1202 for my $region (list) { 1493 for my $region (list) {
1203 if ($region->match && $path =~ $region->match) { 1494 if ($region->{match} && $path =~ $region->{match}) {
1204 ($match, $specificity) = ($region, $region->specificity) 1495 ($match, $specificity) = ($region, $region->specificity)
1205 if $region->specificity > $specificity; 1496 if $region->specificity > $specificity;
1206 } 1497 }
1207 } 1498 }
1208 1499
… …
1272 my ($self, $merge) = @_; 1563 my ($self, $merge) = @_;
1273 1564
1274 # we have to keep some variables in memory intact 1565 # we have to keep some variables in memory intact
1275 local $self->{path}; 1566 local $self->{path};
1276 local $self->{load_path}; 1567 local $self->{load_path};
1277 local $self->{deny_save};
1278 local $self->{deny_reset};
1279 1568
1280 $self->SUPER::thawer_merge ($merge); 1569 $self->SUPER::thawer_merge ($merge);
1281} 1570}
1282 1571
1283sub normalise { 1572sub normalise {
… …
1383 1672
1384 $_->change_map_light ($change) 1673 $_->change_map_light ($change)
1385 for grep $_->outdoor, values %cf::MAP; 1674 for grep $_->outdoor, values %cf::MAP;
1386} 1675}
1387 1676
1677sub decay_objects {
1678 my ($self) = @_;
1679
1680 return if $self->{deny_reset};
1681
1682 $self->do_decay_objects;
1683}
1684
1388sub unlink_save { 1685sub unlink_save {
1389 my ($self) = @_; 1686 my ($self) = @_;
1390 1687
1391 utf8::encode (my $save = $self->save_path); 1688 utf8::encode (my $save = $self->save_path);
1392 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1689 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1448 $self->load_header_orig 1745 $self->load_header_orig
1449 or return; 1746 or return;
1450 $self->prepare_orig; 1747 $self->prepare_orig;
1451 } 1748 }
1452 1749
1750 $self->{deny_reset} = 1
1751 if $self->no_reset;
1752
1453 $self->default_region (cf::region::find_by_path $self->{path}) 1753 $self->default_region (cf::region::find_by_path $self->{path})
1454 unless $self->default_region; 1754 unless $self->default_region;
1455 1755
1456 1 1756 1
1457} 1757}
… …
1472 $map->{last_save} = $cf::RUNTIME; 1772 $map->{last_save} = $cf::RUNTIME;
1473 1773
1474 $map->load_header 1774 $map->load_header
1475 or return; 1775 or return;
1476 1776
1477 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1777 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1478 # doing this can freeze the server in a sync job, obviously 1778 # doing this can freeze the server in a sync job, obviously
1479 #$cf::WAIT_FOR_TICK->wait; 1779 #$cf::WAIT_FOR_TICK->wait;
1480 $map->reset; 1780 $map->reset;
1481 undef $guard; 1781 undef $guard;
1482 return find $path; 1782 return find $path;
… …
1549 my ($self, $ob) = @_; 1849 my ($self, $ob) = @_;
1550 1850
1551 return find "~" . $ob->name . "/" . $self->{path} 1851 return find "~" . $ob->name . "/" . $self->{path}
1552 if $self->per_player; 1852 if $self->per_player;
1553 1853
1854# return find "?party/" . $ob->name . "/" . $self->{path}
1855# if $self->per_party;
1856
1554 $self 1857 $self
1555} 1858}
1556 1859
1557# 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
1558sub load_diag { 1861sub load_diag {
… …
1668 1971
1669sub reset_at { 1972sub reset_at {
1670 my ($self) = @_; 1973 my ($self) = @_;
1671 1974
1672 # TODO: safety, remove and allow resettable per-player maps 1975 # TODO: safety, remove and allow resettable per-player maps
1673 return 1e99 if $self->isa ("ext::map_per_player");#d#
1674 return 1e99 if $self->{deny_reset}; 1976 return 1e99 if $self->{deny_reset};
1675 1977
1676 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1978 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1677 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;
1678 1980
… …
1689 my ($self) = @_; 1991 my ($self) = @_;
1690 1992
1691 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1993 my $lock = cf::lock_acquire "map_data:$self->{path}";
1692 1994
1693 return if $self->players; 1995 return if $self->players;
1694 return if $self->isa ("ext::map_per_player");#d#
1695 1996
1696 warn "resetting map ", $self->path;#d# 1997 warn "resetting map ", $self->path;
1697 1998
1698 $self->in_memory (cf::MAP_SWAPPED); 1999 $self->in_memory (cf::MAP_SWAPPED);
1699 2000
1700 # need to save uniques path 2001 # need to save uniques path
1701 unless ($self->{deny_save}) { 2002 unless ($self->{deny_save}) {
… …
1733 $cf::MAP{$self->path} = $self; 2034 $cf::MAP{$self->path} = $self;
1734 2035
1735 $self->reset; # polite request, might not happen 2036 $self->reset; # polite request, might not happen
1736} 2037}
1737 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
1738=item cf::map::unique_maps 2075=item cf::map::unique_maps
1739 2076
1740Returns an arrayref of paths of all shared maps that have 2077Returns an arrayref of paths of all shared maps that have
1741instantiated unique items. May block. 2078instantiated unique items. May block.
1742 2079
1743=cut 2080=cut
1744 2081
1745sub unique_maps() { 2082sub unique_maps() {
1746 my $files = aio_readdir $UNIQUEDIR 2083 [
1747 or return; 2084 map {
1748
1749 my @paths;
1750
1751 for (@$files) {
1752 utf8::decode $_; 2085 utf8::decode $_;
1753 next if /\.pst$/; 2086 /\.map$/
1754 next unless /^$PATH_SEP/o; 2087 ? normalise $_
1755 2088 : ()
1756 push @paths, cf::map::normalise $_; 2089 } @{ aio_readdir $UNIQUEDIR or [] }
1757 } 2090 ]
1758
1759 \@paths
1760} 2091}
1761 2092
1762package cf; 2093package cf;
1763 2094
1764=back 2095=back
… …
1810 2141
1811 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2142 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1812 2143
1813 if ($self->{record_replies}) { 2144 if ($self->{record_replies}) {
1814 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2145 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2146
1815 } 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 {
1816 $msg = $npc->name . " says: $msg" if $npc; 2160 $msg = $npc->name . " says: $msg" if $npc;
1817 $self->message ($msg, $flags); 2161 $self->message ($msg, $flags);
2162 }
1818 } 2163 }
1819} 2164}
1820 2165
1821=item $player_object->may ("access") 2166=item $player_object->may ("access")
1822 2167
… …
1870 $self->deactivate_recursive; 2215 $self->deactivate_recursive;
1871 2216
1872 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2217 return if UNIVERSAL::isa $self->map, "ext::map_link";
1873 2218
1874 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2219 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1875 if $self->map; 2220 if $self->map && $self->map->{path} ne "{link}";
1876 2221
1877 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2222 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1878} 2223}
1879 2224
1880sub cf::object::player::leave_link { 2225sub cf::object::player::leave_link {
1881 my ($self, $map, $x, $y) = @_; 2226 my ($self, $map, $x, $y) = @_;
2227
2228 return unless $self->contr->active;
1882 2229
1883 my $link_pos = delete $self->{_link_pos}; 2230 my $link_pos = delete $self->{_link_pos};
1884 2231
1885 unless ($map) { 2232 unless ($map) {
1886 # restore original map position 2233 # restore original map position
… …
1909 2256
1910 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2257 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1911 $self->enter_map ($map, $x, $y); 2258 $self->enter_map ($map, $x, $y);
1912} 2259}
1913 2260
1914cf::player->attach (
1915 on_logout => sub {
1916 my ($pl) = @_;
1917
1918 # abort map switching before logout
1919 if ($pl->ob->{_link_pos}) {
1920 cf::sync_job {
1921 $pl->ob->leave_link
1922 };
1923 }
1924 },
1925 on_login => sub {
1926 my ($pl) = @_;
1927
1928 # try to abort aborted map switching on player login :)
1929 # should happen only on crashes
1930 if ($pl->ob->{_link_pos}) {
1931 $pl->ob->enter_link;
1932 (async {
1933 $pl->ob->reply (undef,
1934 "There was an internal problem at your last logout, "
1935 . "the server will try to bring you to your intended destination in a second.",
1936 cf::NDI_RED);
1937 # we need this sleep as the login has a concurrent enter_exit running
1938 # and this sleep increases chances of the player not ending up in scorn
1939 Coro::Timer::sleep 1;
1940 $pl->ob->leave_link;
1941 })->prio (2);
1942 }
1943 },
1944);
1945
1946=item $player_object->goto ($path, $x, $y) 2261=item $player_object->goto ($path, $x, $y[, $check->($map)])
1947 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
1948=cut 2268=cut
2269
2270our $GOTOGEN;
1949 2271
1950sub cf::object::player::goto { 2272sub cf::object::player::goto {
1951 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;
1952 2277
1953 $self->enter_link; 2278 $self->enter_link;
1954 2279
1955 (async { 2280 (async {
1956 my $map = eval { 2281 my $map = eval {
1957 my $map = cf::map::find $path; 2282 my $map = cf::map::find $path;
2283
2284 if ($map) {
1958 $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
1959 $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 $@;
1960 } or 2297 }
1961 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1962 2298
2299 if ($gen == $self->{_goto_generation}) {
2300 delete $self->{_goto_generation};
1963 $self->leave_link ($map, $x, $y); 2301 $self->leave_link ($map, $x, $y);
2302 }
1964 })->prio (1); 2303 })->prio (1);
1965} 2304}
1966 2305
1967=item $player_object->enter_exit ($exit_object) 2306=item $player_object->enter_exit ($exit_object)
1968 2307
… …
2037 my $hp = $exit->stats->hp; 2376 my $hp = $exit->stats->hp;
2038 my $sp = $exit->stats->sp; 2377 my $sp = $exit->stats->sp;
2039 2378
2040 $self->enter_link; 2379 $self->enter_link;
2041 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
2042 (async { 2385 (async {
2043 $self->deactivate_recursive; # just to be sure 2386 $self->deactivate_recursive; # just to be sure
2044 unless (eval { 2387 unless (eval {
2045 $self->goto ($slaying, $hp, $sp); 2388 $self->goto ($slaying, $hp, $sp);
2046 2389
… …
2073 2416
2074 utf8::encode $text; 2417 utf8::encode $text;
2075 $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);
2076} 2419}
2077 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
2078=item $client->ext_event ($type, %msg) 2461=item $client->ext_event ($type, %msg)
2079 2462
2080Sends an exti event to the client. 2463Sends an ext event to the client.
2081 2464
2082=cut 2465=cut
2083 2466
2084sub cf::client::ext_event($$%) { 2467sub cf::client::ext_event($$%) {
2085 my ($self, $type, %msg) = @_; 2468 my ($self, $type, %msg) = @_;
2086 2469
2470 return unless $self->extcmd;
2471
2087 $msg{msgtype} = "event_$type"; 2472 $msg{msgtype} = "event_$type";
2088 $self->send_packet ("ext " . cf::to_json \%msg); 2473 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2089} 2474}
2090 2475
2091=item $success = $client->query ($flags, "text", \&cb) 2476=item $success = $client->query ($flags, "text", \&cb)
2092 2477
2093Queues a query to the client, calling the given callback with 2478Queues a query to the client, calling the given callback with
2094the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2479the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2095C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2480C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2096 2481
2097Queries can fail, so check the return code. Or don't, as queries will become 2482Queries can fail, so check the return code. Or don't, as queries will
2098reliable at some point in the future. 2483become reliable at some point in the future.
2099 2484
2100=cut 2485=cut
2101 2486
2102sub cf::client::query { 2487sub cf::client::query {
2103 my ($self, $flags, $text, $cb) = @_; 2488 my ($self, $flags, $text, $cb) = @_;
… …
2111 utf8::encode $text; 2496 utf8::encode $text;
2112 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2497 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2113 2498
2114 $self->send_packet ($self->{query_queue}[0][0]) 2499 $self->send_packet ($self->{query_queue}[0][0])
2115 if @{ $self->{query_queue} } == 1; 2500 if @{ $self->{query_queue} } == 1;
2501
2502 1
2116} 2503}
2117 2504
2118cf::client->attach ( 2505cf::client->attach (
2506 on_connect => sub {
2507 my ($ns) = @_;
2508
2509 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2510 },
2119 on_reply => sub { 2511 on_reply => sub {
2120 my ($ns, $msg) = @_; 2512 my ($ns, $msg) = @_;
2121 2513
2122 # this weird shuffling is so that direct followup queries 2514 # this weird shuffling is so that direct followup queries
2123 # get handled first 2515 # get handled first
… …
2135 } else { 2527 } else {
2136 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2528 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2137 } 2529 }
2138 } 2530 }
2139 }, 2531 },
2532 on_exticmd => sub {
2533 my ($ns, $buf) = @_;
2534
2535 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2536
2537 if (ref $msg) {
2538 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2539 if (my %reply = $cb->($ns, $msg)) {
2540 $reply{msgid} = $msg->{msgid};
2541 $ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2542 }
2543 }
2544 } else {
2545 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2546 }
2547
2548 cf::override;
2549 },
2140); 2550);
2141 2551
2142=item $client->async (\&cb) 2552=item $client->async (\&cb)
2143 2553
2144Create a new coroutine, running the specified callback. The coroutine will 2554Create a new coroutine, running the specified callback. The coroutine will
… …
2193 2603
2194=pod 2604=pod
2195 2605
2196The following functions and methods are available within a safe environment: 2606The following functions and methods are available within a safe environment:
2197 2607
2198 cf::object contr pay_amount pay_player map 2608 cf::object
2609 contr pay_amount pay_player map x y force_find force_add
2610 insert remove
2611
2199 cf::object::player player 2612 cf::object::player
2200 cf::player peaceful 2613 player
2201 cf::map trigger 2614
2615 cf::player
2616 peaceful
2617
2618 cf::map
2619 trigger
2202 2620
2203=cut 2621=cut
2204 2622
2205for ( 2623for (
2206 ["cf::object" => qw(contr pay_amount pay_player map)], 2624 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2625 insert remove)],
2207 ["cf::object::player" => qw(player)], 2626 ["cf::object::player" => qw(player)],
2208 ["cf::player" => qw(peaceful)], 2627 ["cf::player" => qw(peaceful)],
2209 ["cf::map" => qw(trigger)], 2628 ["cf::map" => qw(trigger)],
2210) { 2629) {
2211 no strict 'refs'; 2630 no strict 'refs';
… …
2282=back 2701=back
2283 2702
2284=cut 2703=cut
2285 2704
2286############################################################################# 2705#############################################################################
2287
2288=head2 EXTENSION DATABASE SUPPORT
2289
2290Crossfire maintains a very simple database for extension use. It can
2291currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2292convert to/from binary).
2293
2294The parameter C<$family> should best start with the name of the extension
2295using it, it should be unique.
2296
2297=over 4
2298
2299=item $value = cf::db_get $family => $key
2300
2301Returns a single value from the database.
2302
2303=item cf::db_put $family => $key => $value
2304
2305Stores the given C<$value> in the family.
2306
2307=cut
2308
2309our $DB;
2310
2311sub db_init {
2312 unless ($DB) {
2313 $DB = BDB::db_create $DB_ENV;
2314
2315 cf::sync_job {
2316 eval {
2317 $DB->set_flags (BDB::CHKSUM);
2318
2319 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2320 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2321 cf::cleanup "db_open(db): $!" if $!;
2322 };
2323 cf::cleanup "db_open(db): $@" if $@;
2324 };
2325 }
2326}
2327
2328sub db_get($$) {
2329 my $key = "$_[0]/$_[1]";
2330
2331 cf::sync_job {
2332 BDB::db_get $DB, undef, $key, my $data;
2333
2334 $! ? ()
2335 : $data
2336 }
2337}
2338
2339sub db_put($$$) {
2340 BDB::dbreq_pri 4;
2341 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2342}
2343
2344=item cf::cache $id => [$paths...], $processversion => $process
2345
2346Generic caching function that returns the value of the resource $id,
2347caching and regenerating as required.
2348
2349This function can block.
2350
2351=cut
2352
2353sub cache {
2354 my ($id, $src, $processversion, $process) = @_;
2355
2356 my $meta =
2357 join "\x00",
2358 $processversion,
2359 map {
2360 aio_stat $_
2361 and Carp::croak "$_: $!";
2362
2363 ($_, (stat _)[7,9])
2364 } @$src;
2365
2366 my $dbmeta = db_get cache => "$id/meta";
2367 if ($dbmeta ne $meta) {
2368 # changed, we may need to process
2369
2370 my @data;
2371 my $md5;
2372
2373 for (0 .. $#$src) {
2374 0 <= aio_load $src->[$_], $data[$_]
2375 or Carp::croak "$src->[$_]: $!";
2376 }
2377
2378 # if processing is expensive, check
2379 # checksum first
2380 if (1) {
2381 $md5 =
2382 join "\x00",
2383 $processversion,
2384 map {
2385 Coro::cede;
2386 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2387 } 0.. $#$src;
2388
2389
2390 my $dbmd5 = db_get cache => "$id/md5";
2391 if ($dbmd5 eq $md5) {
2392 db_put cache => "$id/meta", $meta;
2393
2394 return db_get cache => "$id/data";
2395 }
2396 }
2397
2398 my $t1 = Time::HiRes::time;
2399 my $data = $process->(\@data);
2400 my $t2 = Time::HiRes::time;
2401
2402 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2403
2404 db_put cache => "$id/data", $data;
2405 db_put cache => "$id/md5" , $md5;
2406 db_put cache => "$id/meta", $meta;
2407
2408 return $data;
2409 }
2410
2411 db_get cache => "$id/data"
2412}
2413
2414=item fork_call { }, $args
2415
2416Executes the given code block with the given arguments in a seperate
2417process, returning the results. Everything must be serialisable with
2418Coro::Storable. May, of course, block. Note that the executed sub may
2419never block itself or use any form of Event handling.
2420
2421=cut
2422
2423sub fork_call(&@) {
2424 my ($cb, @args) = @_;
2425
2426# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2427# or die "socketpair: $!";
2428 pipe my $fh1, my $fh2
2429 or die "pipe: $!";
2430
2431 if (my $pid = fork) {
2432 close $fh2;
2433
2434 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2435 $res = Coro::Storable::thaw $res;
2436
2437 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2438
2439 die $$res unless "ARRAY" eq ref $res;
2440
2441 return wantarray ? @$res : $res->[-1];
2442 } else {
2443 reset_signals;
2444 local $SIG{__WARN__};
2445 local $SIG{__DIE__};
2446 eval {
2447 close $fh1;
2448
2449 my @res = eval { $cb->(@args) };
2450 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2451 };
2452
2453 warn $@ if $@;
2454 _exit 0;
2455 }
2456}
2457
2458
2459
2460#############################################################################
2461# the server's init and main functions 2706# the server's init and main functions
2462 2707
2463sub load_facedata($) { 2708sub load_facedata($) {
2464 my ($path) = @_; 2709 my ($path) = @_;
2465 2710
… …
2477 { 2722 {
2478 my $faces = $facedata->{faceinfo}; 2723 my $faces = $facedata->{faceinfo};
2479 2724
2480 while (my ($face, $info) = each %$faces) { 2725 while (my ($face, $info) = each %$faces) {
2481 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2726 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2482 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2727 cf::face::set_visibility $idx, $info->{visibility};
2728 cf::face::set_magicmap $idx, $info->{magicmap};
2483 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2729 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2484 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2730 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2485 Coro::cede; 2731
2732 cf::cede_to_tick;
2486 } 2733 }
2487 2734
2488 while (my ($face, $info) = each %$faces) { 2735 while (my ($face, $info) = each %$faces) {
2489 next unless $info->{smooth}; 2736 next unless $info->{smooth};
2490 my $idx = cf::face::find $face 2737 my $idx = cf::face::find $face
2491 or next; 2738 or next;
2492 if (my $smooth = cf::face::find $info->{smooth}) { 2739 if (my $smooth = cf::face::find $info->{smooth}) {
2740 cf::face::set_smooth $idx, $smooth;
2493 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2741 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2494 } else { 2742 } else {
2495 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2743 warn "smooth face '$info->{smooth}' not found for face '$face'";
2496 } 2744 }
2497 Coro::cede; 2745
2746 cf::cede_to_tick;
2498 } 2747 }
2499 } 2748 }
2500 2749
2501 { 2750 {
2502 my $anims = $facedata->{animinfo}; 2751 my $anims = $facedata->{animinfo};
2503 2752
2504 while (my ($anim, $info) = each %$anims) { 2753 while (my ($anim, $info) = each %$anims) {
2505 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2754 cf::anim::set $anim, $info->{frames}, $info->{facings};
2506 Coro::cede; 2755 cf::cede_to_tick;
2507 } 2756 }
2508 2757
2509 cf::anim::invalidate_all; # d'oh 2758 cf::anim::invalidate_all; # d'oh
2759 }
2760
2761 {
2762 # TODO: for gcfclient pleasure, we should give resources
2763 # that gcfclient doesn't grok a >10000 face index.
2764 my $res = $facedata->{resource};
2765 my $enc = JSON::XS->new->utf8->canonical;
2766
2767 while (my ($name, $info) = each %$res) {
2768 my $meta = $enc->encode ({
2769 name => $name,
2770 type => $info->{type},
2771 copyright => $info->{copyright}, #TODO#
2772 });
2773 my $data = pack "(w/a*)*", $meta, $info->{data};
2774 my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2775
2776 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2777 cf::face::set_type $idx, 1;
2778 cf::face::set_data $idx, 0, $data, $chk;
2779
2780 cf::cede_to_tick;
2781 }
2510 } 2782 }
2511 2783
2512 1 2784 1
2513} 2785}
2514 2786
2515sub reload_regions { 2787sub reload_regions {
2516 load_resource_file "$MAPDIR/regions" 2788 load_resource_file "$MAPDIR/regions"
2517 or die "unable to load regions file\n"; 2789 or die "unable to load regions file\n";
2790
2791 for (cf::region::list) {
2792 $_->{match} = qr/$_->{match}/
2793 if exists $_->{match};
2794 }
2518} 2795}
2519 2796
2520sub reload_facedata { 2797sub reload_facedata {
2521 load_facedata "$DATADIR/facedata" 2798 load_facedata "$DATADIR/facedata"
2522 or die "unable to load facedata\n"; 2799 or die "unable to load facedata\n";
2523} 2800}
2524 2801
2525sub reload_archetypes { 2802sub reload_archetypes {
2526 load_resource_file "$DATADIR/archetypes" 2803 load_resource_file "$DATADIR/archetypes"
2527 or die "unable to load archetypes\n"; 2804 or die "unable to load archetypes\n";
2805 #d# NEED to laod twice to resolve forward references
2806 # this really needs to be done in an extra post-pass
2807 # (which needs to be synchronous, so solve it differently)
2808 load_resource_file "$DATADIR/archetypes"
2809 or die "unable to load archetypes\n";
2528} 2810}
2529 2811
2530sub reload_treasures { 2812sub reload_treasures {
2531 load_resource_file "$DATADIR/treasures" 2813 load_resource_file "$DATADIR/treasures"
2532 or die "unable to load treasurelists\n"; 2814 or die "unable to load treasurelists\n";
… …
2535sub reload_resources { 2817sub reload_resources {
2536 warn "reloading resource files...\n"; 2818 warn "reloading resource files...\n";
2537 2819
2538 reload_regions; 2820 reload_regions;
2539 reload_facedata; 2821 reload_facedata;
2822 #reload_archetypes;#d#
2540 reload_archetypes; 2823 reload_archetypes;
2541 reload_treasures; 2824 reload_treasures;
2542 2825
2543 warn "finished reloading resource files\n"; 2826 warn "finished reloading resource files\n";
2544} 2827}
… …
2601 }, 2884 },
2602 ); 2885 );
2603 } 2886 }
2604} 2887}
2605 2888
2889sub write_runtime {
2890 my $runtime = "$LOCALDIR/runtime";
2891
2892 # first touch the runtime file to show we are still running:
2893 # the fsync below can take a very very long time.
2894
2895 IO::AIO::aio_utime $runtime, undef, undef;
2896
2897 my $guard = cf::lock_acquire "write_runtime";
2898
2899 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2900 or return;
2901
2902 my $value = $cf::RUNTIME + 90 + 10;
2903 # 10 is the runtime save interval, for a monotonic clock
2904 # 60 allows for the watchdog to kill the server.
2905
2906 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2907 and return;
2908
2909 # always fsync - this file is important
2910 aio_fsync $fh
2911 and return;
2912
2913 # touch it again to show we are up-to-date
2914 aio_utime $fh, undef, undef;
2915
2916 close $fh
2917 or return;
2918
2919 aio_rename "$runtime~", $runtime
2920 and return;
2921
2922 warn "runtime file written.\n";
2923
2924 1
2925}
2926
2606sub emergency_save() { 2927sub emergency_save() {
2607 my $freeze_guard = cf::freeze_mainloop; 2928 my $freeze_guard = cf::freeze_mainloop;
2608 2929
2609 warn "enter emergency perl save\n"; 2930 warn "enter emergency perl save\n";
2610 2931
… …
2685 %EXT_CORO = (); 3006 %EXT_CORO = ();
2686 3007
2687 warn "removing commands"; 3008 warn "removing commands";
2688 %COMMAND = (); 3009 %COMMAND = ();
2689 3010
2690 warn "removing ext commands"; 3011 warn "removing ext/exti commands";
2691 %EXTCMD = (); 3012 %EXTCMD = ();
3013 %EXTICMD = ();
2692 3014
2693 warn "unloading/nuking all extensions"; 3015 warn "unloading/nuking all extensions";
2694 for my $pkg (@EXTS) { 3016 for my $pkg (@EXTS) {
2695 warn "... unloading $pkg"; 3017 warn "... unloading $pkg";
2696 3018
… …
2814 my $signal = new Coro::Signal; 3136 my $signal = new Coro::Signal;
2815 push @WAIT_FOR_TICK_BEGIN, $signal; 3137 push @WAIT_FOR_TICK_BEGIN, $signal;
2816 $signal->wait; 3138 $signal->wait;
2817} 3139}
2818 3140
3141 my $min = 1e6;#d#
3142 my $avg = 10;
2819$TICK_WATCHER = Event->timer ( 3143$TICK_WATCHER = Event->timer (
2820 reentrant => 0, 3144 reentrant => 0,
2821 parked => 1, 3145 parked => 1,
2822 prio => 0, 3146 prio => 0,
2823 at => $NEXT_TICK || $TICK, 3147 at => $NEXT_TICK || $TICK,
… …
2827 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3151 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2828 unless ++$bug_warning > 10; 3152 unless ++$bug_warning > 10;
2829 return; 3153 return;
2830 } 3154 }
2831 3155
2832 $NOW = Event::time; 3156 $NOW = $tick_start = Event::time;
2833 3157
2834 cf::server_tick; # one server iteration 3158 cf::server_tick; # one server iteration
3159
3160 0 && sync_job {#d#
3161 for(1..10) {
3162 my $t = Event::time;
3163 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3164 or die;
3165
3166 $map->width (50);
3167 $map->height (50);
3168 $map->alloc;
3169 $map->_load_objects ("/tmp/x.map", 1);
3170 my $t = Event::time - $t;
3171
3172 #next unless $t < 0.0013;#d#
3173 if ($t < $min) {
3174 $min = $t;
3175 }
3176 $avg = $avg * 0.99 + $t * 0.01;
3177 }
3178 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3179 exit 0;
3180 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3181 };
2835 3182
2836 $RUNTIME += $TICK; 3183 $RUNTIME += $TICK;
2837 $NEXT_TICK += $TICK; 3184 $NEXT_TICK += $TICK;
2838 3185
2839 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3186 if ($NOW >= $NEXT_RUNTIME_WRITE) {
… …
2845 } 3192 }
2846 3193
2847# my $AFTER = Event::time; 3194# my $AFTER = Event::time;
2848# warn $AFTER - $NOW;#d# 3195# warn $AFTER - $NOW;#d#
2849 3196
3197 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3198 $sig->send;
3199 }
3200 while (my $sig = shift @WAIT_FOR_TICK) {
3201 $sig->send;
3202 }
3203
3204 $NOW = Event::time;
3205
2850 # if we are delayed by four ticks or more, skip them all 3206 # if we are delayed by four ticks or more, skip them all
2851 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3207 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2852 3208
2853 $TICK_WATCHER->at ($NEXT_TICK); 3209 $TICK_WATCHER->at ($NEXT_TICK);
2854 $TICK_WATCHER->start; 3210 $TICK_WATCHER->start;
2855 3211
2856 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3212 $LOAD = ($NOW - $tick_start) / $TICK;
2857 $sig->send; 3213 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2858 }
2859 while (my $sig = shift @WAIT_FOR_TICK) {
2860 $sig->send;
2861 }
2862 3214
2863 _post_tick; 3215 _post_tick;
3216
3217
2864 }, 3218 },
2865); 3219);
2866 3220
2867{ 3221{
2868 BDB::max_poll_time $TICK * 0.1; 3222 BDB::max_poll_time $TICK * 0.1;

Diff Legend

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