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.264 by root, Sun May 6 05:44:48 2007 UTC vs.
Revision 1.302 by root, Tue Jul 10 16:23:59 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 $runtime = "$LOCALDIR/runtime";
373 407
374 # first touch the runtime file to show we are still running: 408Executes the given code block with the given arguments in a seperate
375 # the fsync below can take a very very long time. 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.
376 412
377 warn "touching runtime...\n";#d# 413=cut
378 if (my $fh = aio_open $runtime, O_WRONLY, 0) {
379 utime undef, undef, $fh;
380 }
381 414
382 my $guard = cf::lock_acquire "write_runtime"; 415sub _store_scalar {
383 416 open my $fh, ">", \my $buf
384 warn "starting to write runtime...\n";#d# 417 or die "fork_call: cannot open fh-to-buf in child : $!";
385 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 418 Storable::store_fd $_[0], $fh;
386 or return;
387
388 my $value = $cf::RUNTIME + 90 + 10;
389 # 10 is the runtime save interval, for a monotonic clock
390 # 60 allows for the watchdog to kill the server.
391
392 (aio_write $fh, 0, (length $value), $value, 0) <= 0
393 and return;
394
395 # always fsync - this file is important
396 aio_fsync $fh
397 and return;
398
399 # touch it again to show we are up-to-date
400 utime undef, undef, $fh;
401
402 close $fh 419 close $fh;
403 or return;
404 420
405 aio_rename "$runtime~", $runtime 421 $buf
406 and return; 422}
407 423
408 warn "... done writing runtime.\n";#d# 424sub fork_call(&@) {
425 my ($cb, @args) = @_;
409 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;
410 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"
411} 582}
412 583
413=item cf::datalog type => key => value, ... 584=item cf::datalog type => key => value, ...
414 585
415Log 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.
… …
433attach callbacks/event handlers (a collection of which is called an "attachment") 604attach callbacks/event handlers (a collection of which is called an "attachment")
434to it. All such attachable objects support the following methods. 605to it. All such attachable objects support the following methods.
435 606
436In 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>
437C<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
438crossfire+). 609Crossfire TRT).
439 610
440=over 4 611=over 4
441 612
442=item $attachable->attach ($attachment, key => $value...) 613=item $attachable->attach ($attachment, key => $value...)
443 614
… …
606 $registry = $CB_TYPE[$object_type] ||= []; 777 $registry = $CB_TYPE[$object_type] ||= [];
607 778
608 } elsif ($type eq "subtype") { 779 } elsif ($type eq "subtype") {
609 defined $object_type or Carp::croak "subtype specified without type"; 780 defined $object_type or Carp::croak "subtype specified without type";
610 my $object_subtype = shift @arg; 781 my $object_subtype = shift @arg;
611 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 782 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
612 783
613 } elsif ($type eq "package") { 784 } elsif ($type eq "package") {
614 my $pkg = shift @arg; 785 my $pkg = shift @arg;
615 786
616 while (my ($name, $id) = each %cb_id) { 787 while (my ($name, $id) = each %cb_id) {
… …
645 _attach $registry, $klass, @attach; 816 _attach $registry, $klass, @attach;
646 } 817 }
647 818
648 $obj->{$name} = \%arg; 819 $obj->{$name} = \%arg;
649 } else { 820 } else {
650 warn "object uses attachment '$name' that is not available, postponing.\n"; 821 warn "object uses attachment '$name' which is not available, postponing.\n";
651 } 822 }
652 823
653 $obj->{_attachment}{$name} = undef; 824 $obj->{_attachment}{$name} = undef;
654} 825}
655 826
… …
657 if (ref $_[0]) { 828 if (ref $_[0]) {
658 _object_attach @_; 829 _object_attach @_;
659 } else { 830 } else {
660 _attach shift->_attach_registry, @_; 831 _attach shift->_attach_registry, @_;
661 } 832 }
833 _recalc_want;
662}; 834};
663 835
664# all those should be optimised 836# all those should be optimised
665sub cf::attachable::detach { 837sub cf::attachable::detach {
666 my ($obj, $name) = @_; 838 my ($obj, $name) = @_;
… …
669 delete $obj->{_attachment}{$name}; 841 delete $obj->{_attachment}{$name};
670 reattach ($obj); 842 reattach ($obj);
671 } else { 843 } else {
672 Carp::croak "cannot, currently, detach class attachments"; 844 Carp::croak "cannot, currently, detach class attachments";
673 } 845 }
846 _recalc_want;
674}; 847};
675 848
676sub cf::attachable::attached { 849sub cf::attachable::attached {
677 my ($obj, $name) = @_; 850 my ($obj, $name) = @_;
678 851
… …
851 or return; 1024 or return;
852 $av = eval { (Storable::thaw $av)->{objs} }; 1025 $av = eval { (Storable::thaw $av)->{objs} };
853 } 1026 }
854 1027
855 warn sprintf "loading %s (%d)\n", 1028 warn sprintf "loading %s (%d)\n",
856 $filename, length $data, scalar @{$av || []};#d# 1029 $filename, length $data, scalar @{$av || []};
857 return ($data, $av); 1030 return ($data, $av);
858} 1031}
1032
1033=head2 COMMAND CALLBACKS
1034
1035=over 4
1036
1037=cut
859 1038
860############################################################################# 1039#############################################################################
861# command handling &c 1040# command handling &c
862 1041
863=item cf::register_command $name => \&callback($ob,$args); 1042=item cf::register_command $name => \&callback($ob,$args);
… …
876 push @{ $COMMAND{$name} }, [$caller, $cb]; 1055 push @{ $COMMAND{$name} }, [$caller, $cb];
877} 1056}
878 1057
879=item cf::register_extcmd $name => \&callback($pl,$packet); 1058=item cf::register_extcmd $name => \&callback($pl,$packet);
880 1059
881Register 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.
882 1065
883If 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
884called. 1067called.
885 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
886=cut 1080=cut
887 1081
888sub register_extcmd { 1082sub register_extcmd {
889 my ($name, $cb) = @_; 1083 my ($name, $cb) = @_;
890 1084
891 $EXTCMD{$name} = $cb; 1085 $EXTCMD{$name} = $cb;
1086}
1087
1088sub register_exticmd {
1089 my ($name, $cb) = @_;
1090
1091 $EXTICMD{$name} = $cb;
892} 1092}
893 1093
894cf::player->attach ( 1094cf::player->attach (
895 on_command => sub { 1095 on_command => sub {
896 my ($pl, $name, $params) = @_; 1096 my ($pl, $name, $params) = @_;
… …
905 cf::override; 1105 cf::override;
906 }, 1106 },
907 on_extcmd => sub { 1107 on_extcmd => sub {
908 my ($pl, $buf) = @_; 1108 my ($pl, $buf) = @_;
909 1109
910 my $msg = eval { from_json $buf }; 1110 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
911 1111
912 if (ref $msg) { 1112 if (ref $msg) {
913 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1113 if (my $cb = $EXTCMD{$msg->{msgtype}}) {
914 if (my %reply = $cb->($pl, $msg)) { 1114 if (my %reply = $cb->($pl, $msg)) {
915 $pl->ext_reply ($msg->{msgid}, %reply); 1115 $pl->ext_reply ($msg->{msgid}, %reply);
… …
921 1121
922 cf::override; 1122 cf::override;
923 }, 1123 },
924); 1124);
925 1125
926sub load_extension {
927 my ($path) = @_;
928
929 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
930 my $base = $1;
931 my $pkg = $1;
932 $pkg =~ s/[^[:word:]]/_/g;
933 $pkg = "ext::$pkg";
934
935 warn "... loading '$path' into '$pkg'\n";
936
937 open my $fh, "<:utf8", $path
938 or die "$path: $!";
939
940 my $source =
941 "package $pkg; use strict; use utf8;\n"
942 . "#line 1 \"$path\"\n{\n"
943 . (do { local $/; <$fh> })
944 . "\n};\n1";
945
946 unless (eval $source) {
947 my $msg = $@ ? "$path: $@\n"
948 : "extension disabled.\n";
949 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
950 warn $@;
951 warn "mandatory extension failed to load, exiting.\n";
952 exit 1;
953 }
954 die $@;
955 }
956
957 push @EXTS, $pkg;
958}
959
960sub load_extensions { 1126sub load_extensions {
1127 cf::sync_job {
1128 my %todo;
1129
961 for my $ext (<$LIBDIR/*.ext>) { 1130 for my $path (<$LIBDIR/*.ext>) {
962 next unless -r $ext; 1131 next unless -r $path;
963 eval { 1132
964 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;
965 1 1190 }
966 } or warn "$ext not loaded: $@"; 1191
1192 skip:
1193 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1194 unless $progress;
1195 }
967 } 1196 };
968} 1197}
969 1198
970############################################################################# 1199#############################################################################
1200
1201=back
971 1202
972=head2 CORE EXTENSIONS 1203=head2 CORE EXTENSIONS
973 1204
974Functions and methods that extend core crossfire objects. 1205Functions and methods that extend core crossfire objects.
975 1206
… …
1163 } 1394 }
1164 1395
1165 \@paths 1396 \@paths
1166} 1397}
1167 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
1168=item $player->ext_reply ($msgid, %msg) 1449=item $player->ext_reply ($msgid, %msg)
1169 1450
1170Sends an ext reply to the player. 1451Sends an ext reply to the player.
1171 1452
1172=cut 1453=cut
1173 1454
1174sub ext_reply($$%) { 1455sub ext_reply($$%) {
1175 my ($self, $id, %msg) = @_; 1456 my ($self, $id, %msg) = @_;
1176 1457
1177 $msg{msgid} = $id; 1458 $msg{msgid} = $id;
1178 1459 $self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1179 $self->send ("ext " . cf::to_json \%msg);
1180} 1460}
1181 1461
1182=item $player->ext_event ($type, %msg) 1462=item $player->ext_event ($type, %msg)
1183 1463
1184Sends an ext event to the client. 1464Sends an ext event to the client.
… …
1199 1479
1200package cf::region; 1480package cf::region;
1201 1481
1202=item cf::region::find_by_path $path 1482=item cf::region::find_by_path $path
1203 1483
1204Tries 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.
1205 1485
1206=cut 1486=cut
1207 1487
1208sub find_by_path($) { 1488sub find_by_path($) {
1209 my ($path) = @_; 1489 my ($path) = @_;
… …
1283 my ($self, $merge) = @_; 1563 my ($self, $merge) = @_;
1284 1564
1285 # we have to keep some variables in memory intact 1565 # we have to keep some variables in memory intact
1286 local $self->{path}; 1566 local $self->{path};
1287 local $self->{load_path}; 1567 local $self->{load_path};
1288 local $self->{deny_save};
1289 local $self->{deny_reset};
1290 1568
1291 $self->SUPER::thawer_merge ($merge); 1569 $self->SUPER::thawer_merge ($merge);
1292} 1570}
1293 1571
1294sub normalise { 1572sub normalise {
… …
1394 1672
1395 $_->change_map_light ($change) 1673 $_->change_map_light ($change)
1396 for grep $_->outdoor, values %cf::MAP; 1674 for grep $_->outdoor, values %cf::MAP;
1397} 1675}
1398 1676
1677sub decay_objects {
1678 my ($self) = @_;
1679
1680 return if $self->{deny_reset};
1681
1682 $self->do_decay_objects;
1683}
1684
1399sub unlink_save { 1685sub unlink_save {
1400 my ($self) = @_; 1686 my ($self) = @_;
1401 1687
1402 utf8::encode (my $save = $self->save_path); 1688 utf8::encode (my $save = $self->save_path);
1403 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1689 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1459 $self->load_header_orig 1745 $self->load_header_orig
1460 or return; 1746 or return;
1461 $self->prepare_orig; 1747 $self->prepare_orig;
1462 } 1748 }
1463 1749
1750 $self->{deny_reset} = 1
1751 if $self->no_reset;
1752
1464 $self->default_region (cf::region::find_by_path $self->{path}) 1753 $self->default_region (cf::region::find_by_path $self->{path})
1465 unless $self->default_region; 1754 unless $self->default_region;
1466 1755
1467 1 1756 1
1468} 1757}
… …
1483 $map->{last_save} = $cf::RUNTIME; 1772 $map->{last_save} = $cf::RUNTIME;
1484 1773
1485 $map->load_header 1774 $map->load_header
1486 or return; 1775 or return;
1487 1776
1488 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1777 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1489 # doing this can freeze the server in a sync job, obviously 1778 # doing this can freeze the server in a sync job, obviously
1490 #$cf::WAIT_FOR_TICK->wait; 1779 #$cf::WAIT_FOR_TICK->wait;
1491 $map->reset; 1780 $map->reset;
1492 undef $guard; 1781 undef $guard;
1493 return find $path; 1782 return find $path;
… …
1560 my ($self, $ob) = @_; 1849 my ($self, $ob) = @_;
1561 1850
1562 return find "~" . $ob->name . "/" . $self->{path} 1851 return find "~" . $ob->name . "/" . $self->{path}
1563 if $self->per_player; 1852 if $self->per_player;
1564 1853
1854# return find "?party/" . $ob->name . "/" . $self->{path}
1855# if $self->per_party;
1856
1565 $self 1857 $self
1566} 1858}
1567 1859
1568# 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
1569sub load_diag { 1861sub load_diag {
… …
1679 1971
1680sub reset_at { 1972sub reset_at {
1681 my ($self) = @_; 1973 my ($self) = @_;
1682 1974
1683 # TODO: safety, remove and allow resettable per-player maps 1975 # TODO: safety, remove and allow resettable per-player maps
1684 return 1e99 if $self->isa ("ext::map_per_player");#d#
1685 return 1e99 if $self->{deny_reset}; 1976 return 1e99 if $self->{deny_reset};
1686 1977
1687 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1978 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1688 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;
1689 1980
… …
1700 my ($self) = @_; 1991 my ($self) = @_;
1701 1992
1702 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1993 my $lock = cf::lock_acquire "map_data:$self->{path}";
1703 1994
1704 return if $self->players; 1995 return if $self->players;
1705 return if $self->isa ("ext::map_per_player");#d#
1706 1996
1707 warn "resetting map ", $self->path;#d# 1997 warn "resetting map ", $self->path;
1708 1998
1709 $self->in_memory (cf::MAP_SWAPPED); 1999 $self->in_memory (cf::MAP_SWAPPED);
1710 2000
1711 # need to save uniques path 2001 # need to save uniques path
1712 unless ($self->{deny_save}) { 2002 unless ($self->{deny_save}) {
… …
1744 $cf::MAP{$self->path} = $self; 2034 $cf::MAP{$self->path} = $self;
1745 2035
1746 $self->reset; # polite request, might not happen 2036 $self->reset; # polite request, might not happen
1747} 2037}
1748 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
1749=item cf::map::unique_maps 2075=item cf::map::unique_maps
1750 2076
1751Returns an arrayref of paths of all shared maps that have 2077Returns an arrayref of paths of all shared maps that have
1752instantiated unique items. May block. 2078instantiated unique items. May block.
1753 2079
1754=cut 2080=cut
1755 2081
1756sub unique_maps() { 2082sub unique_maps() {
1757 my $files = aio_readdir $UNIQUEDIR 2083 [
1758 or return; 2084 map {
1759
1760 my @paths;
1761
1762 for (@$files) {
1763 utf8::decode $_; 2085 utf8::decode $_;
1764 next if /\.pst$/; 2086 /\.map$/
1765 next unless /^$PATH_SEP/o; 2087 ? normalise $_
1766 2088 : ()
1767 push @paths, cf::map::normalise $_; 2089 } @{ aio_readdir $UNIQUEDIR or [] }
1768 } 2090 ]
1769
1770 \@paths
1771} 2091}
1772 2092
1773package cf; 2093package cf;
1774 2094
1775=back 2095=back
… …
1821 2141
1822 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2142 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1823 2143
1824 if ($self->{record_replies}) { 2144 if ($self->{record_replies}) {
1825 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2145 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2146
1826 } 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 {
1827 $msg = $npc->name . " says: $msg" if $npc; 2160 $msg = $npc->name . " says: $msg" if $npc;
1828 $self->message ($msg, $flags); 2161 $self->message ($msg, $flags);
2162 }
1829 } 2163 }
1830} 2164}
1831 2165
1832=item $player_object->may ("access") 2166=item $player_object->may ("access")
1833 2167
… …
1881 $self->deactivate_recursive; 2215 $self->deactivate_recursive;
1882 2216
1883 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2217 return if UNIVERSAL::isa $self->map, "ext::map_link";
1884 2218
1885 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2219 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1886 if $self->map; 2220 if $self->map && $self->map->{path} ne "{link}";
1887 2221
1888 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2222 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1889} 2223}
1890 2224
1891sub cf::object::player::leave_link { 2225sub cf::object::player::leave_link {
1892 my ($self, $map, $x, $y) = @_; 2226 my ($self, $map, $x, $y) = @_;
2227
2228 return unless $self->contr->active;
1893 2229
1894 my $link_pos = delete $self->{_link_pos}; 2230 my $link_pos = delete $self->{_link_pos};
1895 2231
1896 unless ($map) { 2232 unless ($map) {
1897 # restore original map position 2233 # restore original map position
… …
1920 2256
1921 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2257 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1922 $self->enter_map ($map, $x, $y); 2258 $self->enter_map ($map, $x, $y);
1923} 2259}
1924 2260
1925cf::player->attach (
1926 on_logout => sub {
1927 my ($pl) = @_;
1928
1929 # abort map switching before logout
1930 if ($pl->ob->{_link_pos}) {
1931 cf::sync_job {
1932 $pl->ob->leave_link
1933 };
1934 }
1935 },
1936 on_login => sub {
1937 my ($pl) = @_;
1938
1939 # try to abort aborted map switching on player login :)
1940 # should happen only on crashes
1941 if ($pl->ob->{_link_pos}) {
1942 $pl->ob->enter_link;
1943 (async {
1944 $pl->ob->reply (undef,
1945 "There was an internal problem at your last logout, "
1946 . "the server will try to bring you to your intended destination in a second.",
1947 cf::NDI_RED);
1948 # we need this sleep as the login has a concurrent enter_exit running
1949 # and this sleep increases chances of the player not ending up in scorn
1950 Coro::Timer::sleep 1;
1951 $pl->ob->leave_link;
1952 })->prio (2);
1953 }
1954 },
1955);
1956
1957=item $player_object->goto ($path, $x, $y) 2261=item $player_object->goto ($path, $x, $y[, $check->($map)])
1958 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
1959=cut 2268=cut
2269
2270our $GOTOGEN;
1960 2271
1961sub cf::object::player::goto { 2272sub cf::object::player::goto {
1962 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;
1963 2277
1964 $self->enter_link; 2278 $self->enter_link;
1965 2279
1966 (async { 2280 (async {
1967 my $map = eval { 2281 my $map = eval {
1968 my $map = cf::map::find $path; 2282 my $map = cf::map::find $path;
2283
2284 if ($map) {
1969 $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
1970 $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 $@;
1971 } or 2297 }
1972 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1973 2298
2299 if ($gen == $self->{_goto_generation}) {
2300 delete $self->{_goto_generation};
1974 $self->leave_link ($map, $x, $y); 2301 $self->leave_link ($map, $x, $y);
2302 }
1975 })->prio (1); 2303 })->prio (1);
1976} 2304}
1977 2305
1978=item $player_object->enter_exit ($exit_object) 2306=item $player_object->enter_exit ($exit_object)
1979 2307
… …
2048 my $hp = $exit->stats->hp; 2376 my $hp = $exit->stats->hp;
2049 my $sp = $exit->stats->sp; 2377 my $sp = $exit->stats->sp;
2050 2378
2051 $self->enter_link; 2379 $self->enter_link;
2052 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
2053 (async { 2385 (async {
2054 $self->deactivate_recursive; # just to be sure 2386 $self->deactivate_recursive; # just to be sure
2055 unless (eval { 2387 unless (eval {
2056 $self->goto ($slaying, $hp, $sp); 2388 $self->goto ($slaying, $hp, $sp);
2057 2389
… …
2084 2416
2085 utf8::encode $text; 2417 utf8::encode $text;
2086 $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);
2087} 2419}
2088 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
2089=item $client->ext_event ($type, %msg) 2461=item $client->ext_event ($type, %msg)
2090 2462
2091Sends an exti event to the client. 2463Sends an ext event to the client.
2092 2464
2093=cut 2465=cut
2094 2466
2095sub cf::client::ext_event($$%) { 2467sub cf::client::ext_event($$%) {
2096 my ($self, $type, %msg) = @_; 2468 my ($self, $type, %msg) = @_;
2097 2469
2098 $msg{msgtype} = "event_$type"; 2470 $msg{msgtype} = "event_$type";
2099 $self->send_packet ("ext " . cf::to_json \%msg); 2471 $self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));
2100} 2472}
2101 2473
2102=item $success = $client->query ($flags, "text", \&cb) 2474=item $success = $client->query ($flags, "text", \&cb)
2103 2475
2104Queues a query to the client, calling the given callback with 2476Queues a query to the client, calling the given callback with
2105the 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>,
2106C<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>.
2107 2479
2108Queries 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
2109reliable at some point in the future. 2481become reliable at some point in the future.
2110 2482
2111=cut 2483=cut
2112 2484
2113sub cf::client::query { 2485sub cf::client::query {
2114 my ($self, $flags, $text, $cb) = @_; 2486 my ($self, $flags, $text, $cb) = @_;
… …
2122 utf8::encode $text; 2494 utf8::encode $text;
2123 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2495 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2124 2496
2125 $self->send_packet ($self->{query_queue}[0][0]) 2497 $self->send_packet ($self->{query_queue}[0][0])
2126 if @{ $self->{query_queue} } == 1; 2498 if @{ $self->{query_queue} } == 1;
2499
2500 1
2127} 2501}
2128 2502
2129cf::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 },
2130 on_reply => sub { 2509 on_reply => sub {
2131 my ($ns, $msg) = @_; 2510 my ($ns, $msg) = @_;
2132 2511
2133 # this weird shuffling is so that direct followup queries 2512 # this weird shuffling is so that direct followup queries
2134 # get handled first 2513 # get handled first
… …
2146 } else { 2525 } else {
2147 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2526 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2148 } 2527 }
2149 } 2528 }
2150 }, 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 },
2151); 2548);
2152 2549
2153=item $client->async (\&cb) 2550=item $client->async (\&cb)
2154 2551
2155Create a new coroutine, running the specified callback. The coroutine will 2552Create a new coroutine, running the specified callback. The coroutine will
… …
2204 2601
2205=pod 2602=pod
2206 2603
2207The following functions and methods are available within a safe environment: 2604The following functions and methods are available within a safe environment:
2208 2605
2209 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
2210 cf::object::player player 2610 cf::object::player
2211 cf::player peaceful 2611 player
2212 cf::map trigger 2612
2613 cf::player
2614 peaceful
2615
2616 cf::map
2617 trigger
2213 2618
2214=cut 2619=cut
2215 2620
2216for ( 2621for (
2217 ["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)],
2218 ["cf::object::player" => qw(player)], 2624 ["cf::object::player" => qw(player)],
2219 ["cf::player" => qw(peaceful)], 2625 ["cf::player" => qw(peaceful)],
2220 ["cf::map" => qw(trigger)], 2626 ["cf::map" => qw(trigger)],
2221) { 2627) {
2222 no strict 'refs'; 2628 no strict 'refs';
… …
2293=back 2699=back
2294 2700
2295=cut 2701=cut
2296 2702
2297############################################################################# 2703#############################################################################
2298
2299=head2 EXTENSION DATABASE SUPPORT
2300
2301Crossfire maintains a very simple database for extension use. It can
2302currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2303convert to/from binary).
2304
2305The parameter C<$family> should best start with the name of the extension
2306using it, it should be unique.
2307
2308=over 4
2309
2310=item $value = cf::db_get $family => $key
2311
2312Returns a single value from the database.
2313
2314=item cf::db_put $family => $key => $value
2315
2316Stores the given C<$value> in the family.
2317
2318=cut
2319
2320our $DB;
2321
2322sub db_init {
2323 unless ($DB) {
2324 $DB = BDB::db_create $DB_ENV;
2325
2326 cf::sync_job {
2327 eval {
2328 $DB->set_flags (BDB::CHKSUM);
2329
2330 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2331 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2332 cf::cleanup "db_open(db): $!" if $!;
2333 };
2334 cf::cleanup "db_open(db): $@" if $@;
2335 };
2336 }
2337}
2338
2339sub db_get($$) {
2340 my $key = "$_[0]/$_[1]";
2341
2342 cf::sync_job {
2343 BDB::db_get $DB, undef, $key, my $data;
2344
2345 $! ? ()
2346 : $data
2347 }
2348}
2349
2350sub db_put($$$) {
2351 BDB::dbreq_pri 4;
2352 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2353}
2354
2355=item cf::cache $id => [$paths...], $processversion => $process
2356
2357Generic caching function that returns the value of the resource $id,
2358caching and regenerating as required.
2359
2360This function can block.
2361
2362=cut
2363
2364sub cache {
2365 my ($id, $src, $processversion, $process) = @_;
2366
2367 my $meta =
2368 join "\x00",
2369 $processversion,
2370 map {
2371 aio_stat $_
2372 and Carp::croak "$_: $!";
2373
2374 ($_, (stat _)[7,9])
2375 } @$src;
2376
2377 my $dbmeta = db_get cache => "$id/meta";
2378 if ($dbmeta ne $meta) {
2379 # changed, we may need to process
2380
2381 my @data;
2382 my $md5;
2383
2384 for (0 .. $#$src) {
2385 0 <= aio_load $src->[$_], $data[$_]
2386 or Carp::croak "$src->[$_]: $!";
2387 }
2388
2389 # if processing is expensive, check
2390 # checksum first
2391 if (1) {
2392 $md5 =
2393 join "\x00",
2394 $processversion,
2395 map {
2396 Coro::cede;
2397 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2398 } 0.. $#$src;
2399
2400
2401 my $dbmd5 = db_get cache => "$id/md5";
2402 if ($dbmd5 eq $md5) {
2403 db_put cache => "$id/meta", $meta;
2404
2405 return db_get cache => "$id/data";
2406 }
2407 }
2408
2409 my $t1 = Time::HiRes::time;
2410 my $data = $process->(\@data);
2411 my $t2 = Time::HiRes::time;
2412
2413 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2414
2415 db_put cache => "$id/data", $data;
2416 db_put cache => "$id/md5" , $md5;
2417 db_put cache => "$id/meta", $meta;
2418
2419 return $data;
2420 }
2421
2422 db_get cache => "$id/data"
2423}
2424
2425=item fork_call { }, $args
2426
2427Executes the given code block with the given arguments in a seperate
2428process, returning the results. Everything must be serialisable with
2429Coro::Storable. May, of course, block. Note that the executed sub may
2430never block itself or use any form of Event handling.
2431
2432=cut
2433
2434sub fork_call(&@) {
2435 my ($cb, @args) = @_;
2436
2437# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2438# or die "socketpair: $!";
2439 pipe my $fh1, my $fh2
2440 or die "pipe: $!";
2441
2442 if (my $pid = fork) {
2443 close $fh2;
2444
2445 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2446 $res = Coro::Storable::thaw $res;
2447
2448 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2449
2450 die $$res unless "ARRAY" eq ref $res;
2451
2452 return wantarray ? @$res : $res->[-1];
2453 } else {
2454 reset_signals;
2455 local $SIG{__WARN__};
2456 local $SIG{__DIE__};
2457 eval {
2458 close $fh1;
2459
2460 my @res = eval { $cb->(@args) };
2461 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2462 };
2463
2464 warn $@ if $@;
2465 _exit 0;
2466 }
2467}
2468
2469
2470
2471#############################################################################
2472# the server's init and main functions 2704# the server's init and main functions
2473 2705
2474sub load_facedata($) { 2706sub load_facedata($) {
2475 my ($path) = @_; 2707 my ($path) = @_;
2476 2708
… …
2488 { 2720 {
2489 my $faces = $facedata->{faceinfo}; 2721 my $faces = $facedata->{faceinfo};
2490 2722
2491 while (my ($face, $info) = each %$faces) { 2723 while (my ($face, $info) = each %$faces) {
2492 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2724 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2493 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2725 cf::face::set_visibility $idx, $info->{visibility};
2726 cf::face::set_magicmap $idx, $info->{magicmap};
2494 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 2727 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2495 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 2728 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2496 Coro::cede; 2729
2730 cf::cede_to_tick;
2497 } 2731 }
2498 2732
2499 while (my ($face, $info) = each %$faces) { 2733 while (my ($face, $info) = each %$faces) {
2500 next unless $info->{smooth}; 2734 next unless $info->{smooth};
2501 my $idx = cf::face::find $face 2735 my $idx = cf::face::find $face
2502 or next; 2736 or next;
2503 if (my $smooth = cf::face::find $info->{smooth}) { 2737 if (my $smooth = cf::face::find $info->{smooth}) {
2738 cf::face::set_smooth $idx, $smooth;
2504 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 2739 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2505 } else { 2740 } else {
2506 warn "smooth face '$info->{smooth}' not found for face '$face'"; 2741 warn "smooth face '$info->{smooth}' not found for face '$face'";
2507 } 2742 }
2508 Coro::cede; 2743
2744 cf::cede_to_tick;
2509 } 2745 }
2510 } 2746 }
2511 2747
2512 { 2748 {
2513 my $anims = $facedata->{animinfo}; 2749 my $anims = $facedata->{animinfo};
2514 2750
2515 while (my ($anim, $info) = each %$anims) { 2751 while (my ($anim, $info) = each %$anims) {
2516 cf::anim::set $anim, $info->{frames}, $info->{facings}; 2752 cf::anim::set $anim, $info->{frames}, $info->{facings};
2517 Coro::cede; 2753 cf::cede_to_tick;
2518 } 2754 }
2519 2755
2520 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},
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 use Data::Dumper; warn Dumper substr $data, 0, 100;#d#
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 # TODO
2781 cf::cede_to_tick;
2782 }
2521 } 2783 }
2522 2784
2523 1 2785 1
2524} 2786}
2525 2787
… …
2534} 2796}
2535 2797
2536sub reload_archetypes { 2798sub reload_archetypes {
2537 load_resource_file "$DATADIR/archetypes" 2799 load_resource_file "$DATADIR/archetypes"
2538 or die "unable to load archetypes\n"; 2800 or die "unable to load archetypes\n";
2801 #d# NEED to laod twice to resolve forward references
2802 # this really needs to be done in an extra post-pass
2803 # (which needs to be synchronous, so solve it differently)
2804 load_resource_file "$DATADIR/archetypes"
2805 or die "unable to load archetypes\n";
2539} 2806}
2540 2807
2541sub reload_treasures { 2808sub reload_treasures {
2542 load_resource_file "$DATADIR/treasures" 2809 load_resource_file "$DATADIR/treasures"
2543 or die "unable to load treasurelists\n"; 2810 or die "unable to load treasurelists\n";
… …
2546sub reload_resources { 2813sub reload_resources {
2547 warn "reloading resource files...\n"; 2814 warn "reloading resource files...\n";
2548 2815
2549 reload_regions; 2816 reload_regions;
2550 reload_facedata; 2817 reload_facedata;
2818 #reload_archetypes;#d#
2551 reload_archetypes; 2819 reload_archetypes;
2552 reload_treasures; 2820 reload_treasures;
2553 2821
2554 warn "finished reloading resource files\n"; 2822 warn "finished reloading resource files\n";
2555} 2823}
… …
2612 }, 2880 },
2613 ); 2881 );
2614 } 2882 }
2615} 2883}
2616 2884
2885sub write_runtime {
2886 my $runtime = "$LOCALDIR/runtime";
2887
2888 # first touch the runtime file to show we are still running:
2889 # the fsync below can take a very very long time.
2890
2891 IO::AIO::aio_utime $runtime, undef, undef;
2892
2893 my $guard = cf::lock_acquire "write_runtime";
2894
2895 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2896 or return;
2897
2898 my $value = $cf::RUNTIME + 90 + 10;
2899 # 10 is the runtime save interval, for a monotonic clock
2900 # 60 allows for the watchdog to kill the server.
2901
2902 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2903 and return;
2904
2905 # always fsync - this file is important
2906 aio_fsync $fh
2907 and return;
2908
2909 # touch it again to show we are up-to-date
2910 aio_utime $fh, undef, undef;
2911
2912 close $fh
2913 or return;
2914
2915 aio_rename "$runtime~", $runtime
2916 and return;
2917
2918 warn "runtime file written.\n";
2919
2920 1
2921}
2922
2617sub emergency_save() { 2923sub emergency_save() {
2618 my $freeze_guard = cf::freeze_mainloop; 2924 my $freeze_guard = cf::freeze_mainloop;
2619 2925
2620 warn "enter emergency perl save\n"; 2926 warn "enter emergency perl save\n";
2621 2927
… …
2696 %EXT_CORO = (); 3002 %EXT_CORO = ();
2697 3003
2698 warn "removing commands"; 3004 warn "removing commands";
2699 %COMMAND = (); 3005 %COMMAND = ();
2700 3006
2701 warn "removing ext commands"; 3007 warn "removing ext/exti commands";
2702 %EXTCMD = (); 3008 %EXTCMD = ();
3009 %EXTICMD = ();
2703 3010
2704 warn "unloading/nuking all extensions"; 3011 warn "unloading/nuking all extensions";
2705 for my $pkg (@EXTS) { 3012 for my $pkg (@EXTS) {
2706 warn "... unloading $pkg"; 3013 warn "... unloading $pkg";
2707 3014
… …
2825 my $signal = new Coro::Signal; 3132 my $signal = new Coro::Signal;
2826 push @WAIT_FOR_TICK_BEGIN, $signal; 3133 push @WAIT_FOR_TICK_BEGIN, $signal;
2827 $signal->wait; 3134 $signal->wait;
2828} 3135}
2829 3136
3137 my $min = 1e6;#d#
3138 my $avg = 10;
2830$TICK_WATCHER = Event->timer ( 3139$TICK_WATCHER = Event->timer (
2831 reentrant => 0, 3140 reentrant => 0,
2832 parked => 1, 3141 parked => 1,
2833 prio => 0, 3142 prio => 0,
2834 at => $NEXT_TICK || $TICK, 3143 at => $NEXT_TICK || $TICK,
… …
2838 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3147 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2839 unless ++$bug_warning > 10; 3148 unless ++$bug_warning > 10;
2840 return; 3149 return;
2841 } 3150 }
2842 3151
2843 $NOW = Event::time; 3152 $NOW = $tick_start = Event::time;
2844 3153
2845 cf::server_tick; # one server iteration 3154 cf::server_tick; # one server iteration
3155
3156 0 && sync_job {#d#
3157 for(1..10) {
3158 my $t = Event::time;
3159 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3160 or die;
3161
3162 $map->width (50);
3163 $map->height (50);
3164 $map->alloc;
3165 $map->_load_objects ("/tmp/x.map", 1);
3166 my $t = Event::time - $t;
3167
3168 #next unless $t < 0.0013;#d#
3169 if ($t < $min) {
3170 $min = $t;
3171 }
3172 $avg = $avg * 0.99 + $t * 0.01;
3173 }
3174 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3175 exit 0;
3176 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3177 };
2846 3178
2847 $RUNTIME += $TICK; 3179 $RUNTIME += $TICK;
2848 $NEXT_TICK += $TICK; 3180 $NEXT_TICK += $TICK;
2849 3181
2850 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3182 if ($NOW >= $NEXT_RUNTIME_WRITE) {
… …
2856 } 3188 }
2857 3189
2858# my $AFTER = Event::time; 3190# my $AFTER = Event::time;
2859# warn $AFTER - $NOW;#d# 3191# warn $AFTER - $NOW;#d#
2860 3192
3193 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3194 $sig->send;
3195 }
3196 while (my $sig = shift @WAIT_FOR_TICK) {
3197 $sig->send;
3198 }
3199
3200 $NOW = Event::time;
3201
2861 # if we are delayed by four ticks or more, skip them all 3202 # if we are delayed by four ticks or more, skip them all
2862 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3203 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2863 3204
2864 $TICK_WATCHER->at ($NEXT_TICK); 3205 $TICK_WATCHER->at ($NEXT_TICK);
2865 $TICK_WATCHER->start; 3206 $TICK_WATCHER->start;
2866 3207
2867 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3208 $LOAD = ($NOW - $tick_start) / $TICK;
2868 $sig->send; 3209 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2869 }
2870 while (my $sig = shift @WAIT_FOR_TICK) {
2871 $sig->send;
2872 }
2873 3210
2874 _post_tick; 3211 _post_tick;
3212
3213
2875 }, 3214 },
2876); 3215);
2877 3216
2878{ 3217{
2879 BDB::max_poll_time $TICK * 0.1; 3218 BDB::max_poll_time $TICK * 0.1;

Diff Legend

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