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.260 by root, Fri Apr 27 19:53:05 2007 UTC vs.
Revision 1.287 by root, Mon Jun 25 05:43:45 2007 UTC

… …
49our %COMMAND = (); 49our %COMMAND = ();
50our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
51 51
52our @EXTS = (); # list of extension package names 52our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 53our %EXTCMD = ();
54our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 55our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 56our %EXT_MAP = (); # pluggable maps
56 57
57our $RELOAD; # number of reloads so far 58our $RELOAD; # number of reloads so far
58our @EVENT; 59our @EVENT;
… …
90our $LINK_MAP; # the special {link} map, which is always available 91our $LINK_MAP; # the special {link} map, which is always available
91 92
92# used to convert map paths into valid unix filenames by replacing / by ∕ 93# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 94our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 95
96our $LOAD; # a number between 0 (idle) and 1 (too many objects)
97our $LOADAVG; # same thing, but with alpha-smoothing
98our $tick_start; # for load detecting purposes
99
95binmode STDOUT; 100binmode STDOUT;
96binmode STDERR; 101binmode STDERR;
97 102
98# read virtual server time, if available 103# read virtual server time, if available
99unless ($RUNTIME || !-e "$LOCALDIR/runtime") { 104unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
… …
139 144
140=item $cf::TICK 145=item $cf::TICK
141 146
142The interval between server ticks, in seconds. 147The interval between server ticks, in seconds.
143 148
149=item $cf::LOADAVG
150
151The current CPU load on the server (alpha-smoothed), as a value between 0
152(none) and 1 (overloaded), indicating how much time is spent on processing
153objects per tick. Healthy values are < 0.5.
154
155=item $cf::LOAD
156
157The raw value load value from the last tick.
158
144=item %cf::CFG 159=item %cf::CFG
145 160
146Configuration for the server, loaded from C</etc/crossfire/config>, or 161Configuration for the server, loaded from C</etc/crossfire/config>, or
147from wherever your confdir points to. 162from wherever your confdir points to.
148 163
… …
173@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 188@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
174@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 189@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
175@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 190@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
176@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 191@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
177@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable'; 192@safe::cf::map::ISA = @cf::map::ISA = 'cf::attachable';
193@safe::cf::arch::ISA = @cf::arch::ISA = 'cf::object';
178@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; 194@safe::cf::object::player::ISA = @cf::object::player::ISA = 'cf::object'; # not really true (yet)
179 195
180# we bless all objects into (empty) derived classes to force a method lookup 196# we bless all objects into (empty) derived classes to force a method lookup
181# within the Safe compartment. 197# within the Safe compartment.
182for my $pkg (qw( 198for my $pkg (qw(
183 cf::global cf::attachable 199 cf::global cf::attachable
… …
191} 207}
192 208
193$Event::DIED = sub { 209$Event::DIED = sub {
194 warn "error in event callback: @_"; 210 warn "error in event callback: @_";
195}; 211};
212
213#############################################################################
196 214
197=head2 UTILITY FUNCTIONS 215=head2 UTILITY FUNCTIONS
198 216
199=over 4 217=over 4
200 218
… …
219 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 237 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
220 $d 238 $d
221 } || "[unable to dump $_[0]: '$@']"; 239 } || "[unable to dump $_[0]: '$@']";
222} 240}
223 241
224use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working 242use JSON::XS ();
225 243
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->convert_blessed->utf8;
255
256sub to_json ($) { $json_coder->encode ($_[0]) }
257sub from_json ($) { $json_coder->decode ($_[0]) }
233 258
234=item cf::lock_wait $string 259=item cf::lock_wait $string
235 260
236Wait until the given lock is available. See cf::lock_acquire. 261Wait until the given lock is available. See cf::lock_acquire.
237 262
… …
303 328
304BEGIN { *async = \&Coro::async_pool } 329BEGIN { *async = \&Coro::async_pool }
305 330
306=item cf::sync_job { BLOCK } 331=item cf::sync_job { BLOCK }
307 332
308The design of crossfire+ requires that the main coro ($Coro::main) is 333The design of Crossfire TRT requires that the main coroutine ($Coro::main)
309always able to handle events or runnable, as crossfire+ is only partly 334is always able to handle events or runnable, as Crossfire TRT is only
310reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable. 335partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
336acceptable.
311 337
312If it must be done, put the blocking parts into C<sync_job>. This will run 338If it must be done, put the blocking parts into C<sync_job>. This will run
313the given BLOCK in another coroutine while waiting for the result. The 339the given BLOCK in another coroutine while waiting for the result. The
314server will be frozen during this time, so the block should either finish 340server will be frozen during this time, so the block should either finish
315fast or be very important. 341fast or be very important.
… …
318 344
319sub sync_job(&) { 345sub sync_job(&) {
320 my ($job) = @_; 346 my ($job) = @_;
321 347
322 if ($Coro::current == $Coro::main) { 348 if ($Coro::current == $Coro::main) {
349 my $time = Event::time;
350
323 # this is the main coro, too bad, we have to block 351 # this is the main coro, too bad, we have to block
324 # till the operation succeeds, freezing the server :/ 352 # till the operation succeeds, freezing the server :/
325 353
326 # TODO: use suspend/resume instead 354 # TODO: use suspend/resume instead
327 # (but this is cancel-safe) 355 # (but this is cancel-safe)
… …
338 366
339 while ($busy) { 367 while ($busy) {
340 Coro::cede or Event::one_event; 368 Coro::cede or Event::one_event;
341 } 369 }
342 370
371 $time = Event::time - $time;
372
373 LOG llevError | logBacktrace, Carp::longmess "long sync job"
374 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
375
376 $tick_start += $time; # do not account sync jobs to server load
377
343 wantarray ? @res : $res[0] 378 wantarray ? @res : $res[0]
344 } else { 379 } else {
345 # we are in another coroutine, how wonderful, everything just works 380 # we are in another coroutine, how wonderful, everything just works
346 381
347 $job->() 382 $job->()
… …
366 $EXT_CORO{$coro+0} = $coro; 401 $EXT_CORO{$coro+0} = $coro;
367 402
368 $coro 403 $coro
369} 404}
370 405
371sub write_runtime { 406=item fork_call { }, $args
372 my $guard = cf::lock_acquire "write_runtime";
373 407
374 my $runtime = "$LOCALDIR/runtime"; 408Executes the given code block with the given arguments in a seperate
409process, returning the results. Everything must be serialisable with
410Coro::Storable. May, of course, block. Note that the executed sub may
411never block itself or use any form of Event handling.
375 412
376 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 413=cut
377 or return;
378 414
379 my $value = $cf::RUNTIME + 90 + 10; 415sub fork_call(&@) {
380 # 10 is the runtime save interval, for a monotonic clock 416 my ($cb, @args) = @_;
381 # 60 allows for the watchdog to kill the server.
382 417
383 (aio_write $fh, 0, (length $value), $value, 0) <= 0 418# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
384 and return; 419# or die "socketpair: $!";
420 pipe my $fh1, my $fh2
421 or die "pipe: $!";
385 422
386 # always fsync - this file is important 423 if (my $pid = fork) {
387 aio_fsync $fh
388 and return;
389
390 close $fh 424 close $fh2;
391 or return;
392 425
393 aio_rename "$runtime~", $runtime 426 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
394 and return; 427 $res = Coro::Storable::thaw $res;
395 428
429 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
430
431 die $$res unless "ARRAY" eq ref $res;
432
433 return wantarray ? @$res : $res->[-1];
434 } else {
435 reset_signals;
436 local $SIG{__WARN__};
437 local $SIG{__DIE__};
438 eval {
439 close $fh1;
440
441 my @res = eval { $cb->(@args) };
442 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
443 };
444
445 warn $@ if $@;
446 _exit 0;
396 1 447 }
448}
449
450=item $value = cf::db_get $family => $key
451
452Returns a single value from the environment database.
453
454=item cf::db_put $family => $key => $value
455
456Stores the given C<$value> in the family. It can currently store binary
457data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
458
459=cut
460
461our $DB;
462
463sub db_init {
464 unless ($DB) {
465 $DB = BDB::db_create $DB_ENV;
466
467 cf::sync_job {
468 eval {
469 $DB->set_flags (BDB::CHKSUM);
470
471 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
472 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
473 cf::cleanup "db_open(db): $!" if $!;
474 };
475 cf::cleanup "db_open(db): $@" if $@;
476 };
477 }
478}
479
480sub db_get($$) {
481 my $key = "$_[0]/$_[1]";
482
483 cf::sync_job {
484 BDB::db_get $DB, undef, $key, my $data;
485
486 $! ? ()
487 : $data
488 }
489}
490
491sub db_put($$$) {
492 BDB::dbreq_pri 4;
493 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
494}
495
496=item cf::cache $id => [$paths...], $processversion => $process
497
498Generic caching function that returns the value of the resource $id,
499caching and regenerating as required.
500
501This function can block.
502
503=cut
504
505sub cache {
506 my ($id, $src, $processversion, $process) = @_;
507
508 my $meta =
509 join "\x00",
510 $processversion,
511 map {
512 aio_stat $_
513 and Carp::croak "$_: $!";
514
515 ($_, (stat _)[7,9])
516 } @$src;
517
518 my $dbmeta = db_get cache => "$id/meta";
519 if ($dbmeta ne $meta) {
520 # changed, we may need to process
521
522 my @data;
523 my $md5;
524
525 for (0 .. $#$src) {
526 0 <= aio_load $src->[$_], $data[$_]
527 or Carp::croak "$src->[$_]: $!";
528 }
529
530 # if processing is expensive, check
531 # checksum first
532 if (1) {
533 $md5 =
534 join "\x00",
535 $processversion,
536 map {
537 Coro::cede;
538 ($src->[$_], Digest::MD5::md5_hex $data[$_])
539 } 0.. $#$src;
540
541
542 my $dbmd5 = db_get cache => "$id/md5";
543 if ($dbmd5 eq $md5) {
544 db_put cache => "$id/meta", $meta;
545
546 return db_get cache => "$id/data";
547 }
548 }
549
550 my $t1 = Time::HiRes::time;
551 my $data = $process->(\@data);
552 my $t2 = Time::HiRes::time;
553
554 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
555
556 db_put cache => "$id/data", $data;
557 db_put cache => "$id/md5" , $md5;
558 db_put cache => "$id/meta", $meta;
559
560 return $data;
561 }
562
563 db_get cache => "$id/data"
397} 564}
398 565
399=item cf::datalog type => key => value, ... 566=item cf::datalog type => key => value, ...
400 567
401Log a datalog packet of the given type with the given key-value pairs. 568Log a datalog packet of the given type with the given key-value pairs.
… …
419attach callbacks/event handlers (a collection of which is called an "attachment") 586attach callbacks/event handlers (a collection of which is called an "attachment")
420to it. All such attachable objects support the following methods. 587to it. All such attachable objects support the following methods.
421 588
422In the following description, CLASS can be any of C<global>, C<object> 589In the following description, CLASS can be any of C<global>, C<object>
423C<player>, C<client> or C<map> (i.e. the attachable objects in 590C<player>, C<client> or C<map> (i.e. the attachable objects in
424crossfire+). 591Crossfire TRT).
425 592
426=over 4 593=over 4
427 594
428=item $attachable->attach ($attachment, key => $value...) 595=item $attachable->attach ($attachment, key => $value...)
429 596
… …
592 $registry = $CB_TYPE[$object_type] ||= []; 759 $registry = $CB_TYPE[$object_type] ||= [];
593 760
594 } elsif ($type eq "subtype") { 761 } elsif ($type eq "subtype") {
595 defined $object_type or Carp::croak "subtype specified without type"; 762 defined $object_type or Carp::croak "subtype specified without type";
596 my $object_subtype = shift @arg; 763 my $object_subtype = shift @arg;
597 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 764 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
598 765
599 } elsif ($type eq "package") { 766 } elsif ($type eq "package") {
600 my $pkg = shift @arg; 767 my $pkg = shift @arg;
601 768
602 while (my ($name, $id) = each %cb_id) { 769 while (my ($name, $id) = each %cb_id) {
… …
631 _attach $registry, $klass, @attach; 798 _attach $registry, $klass, @attach;
632 } 799 }
633 800
634 $obj->{$name} = \%arg; 801 $obj->{$name} = \%arg;
635 } else { 802 } else {
636 warn "object uses attachment '$name' that is not available, postponing.\n"; 803 warn "object uses attachment '$name' which is not available, postponing.\n";
637 } 804 }
638 805
639 $obj->{_attachment}{$name} = undef; 806 $obj->{_attachment}{$name} = undef;
640} 807}
641 808
… …
643 if (ref $_[0]) { 810 if (ref $_[0]) {
644 _object_attach @_; 811 _object_attach @_;
645 } else { 812 } else {
646 _attach shift->_attach_registry, @_; 813 _attach shift->_attach_registry, @_;
647 } 814 }
815 _recalc_want;
648}; 816};
649 817
650# all those should be optimised 818# all those should be optimised
651sub cf::attachable::detach { 819sub cf::attachable::detach {
652 my ($obj, $name) = @_; 820 my ($obj, $name) = @_;
… …
655 delete $obj->{_attachment}{$name}; 823 delete $obj->{_attachment}{$name};
656 reattach ($obj); 824 reattach ($obj);
657 } else { 825 } else {
658 Carp::croak "cannot, currently, detach class attachments"; 826 Carp::croak "cannot, currently, detach class attachments";
659 } 827 }
828 _recalc_want;
660}; 829};
661 830
662sub cf::attachable::attached { 831sub cf::attachable::attached {
663 my ($obj, $name) = @_; 832 my ($obj, $name) = @_;
664 833
… …
837 or return; 1006 or return;
838 $av = eval { (Storable::thaw $av)->{objs} }; 1007 $av = eval { (Storable::thaw $av)->{objs} };
839 } 1008 }
840 1009
841 warn sprintf "loading %s (%d)\n", 1010 warn sprintf "loading %s (%d)\n",
842 $filename, length $data, scalar @{$av || []};#d# 1011 $filename, length $data, scalar @{$av || []};
843 return ($data, $av); 1012 return ($data, $av);
844} 1013}
1014
1015=head2 COMMAND CALLBACKS
1016
1017=over 4
1018
1019=cut
845 1020
846############################################################################# 1021#############################################################################
847# command handling &c 1022# command handling &c
848 1023
849=item cf::register_command $name => \&callback($ob,$args); 1024=item cf::register_command $name => \&callback($ob,$args);
… …
862 push @{ $COMMAND{$name} }, [$caller, $cb]; 1037 push @{ $COMMAND{$name} }, [$caller, $cb];
863} 1038}
864 1039
865=item cf::register_extcmd $name => \&callback($pl,$packet); 1040=item cf::register_extcmd $name => \&callback($pl,$packet);
866 1041
867Register a callbackf ro execution when the client sends an extcmd packet. 1042Register a callback for execution when the client sends an (synchronous)
1043extcmd packet. Ext commands will be processed in the order they are
1044received by the server, like other user commands. The first argument is
1045the logged-in player. Ext commands can only be processed after a player
1046has logged in successfully.
868 1047
869If the callback returns something, it is sent back as if reply was being 1048If the callback returns something, it is sent back as if reply was being
870called. 1049called.
871 1050
1051=item cf::register_exticmd $name => \&callback($ns,$packet);
1052
1053Register a callback for execution when the client sends an (asynchronous)
1054exticmd packet. Exti commands are processed by the server as soon as they
1055are received, i.e. out of order w.r.t. other commands. The first argument
1056is a client socket. Exti commands can be received anytime, even before
1057log-in.
1058
1059If the callback returns something, it is sent back as if reply was being
1060called.
1061
872=cut 1062=cut
873 1063
874sub register_extcmd { 1064sub register_extcmd {
875 my ($name, $cb) = @_; 1065 my ($name, $cb) = @_;
876 1066
877 $EXTCMD{$name} = $cb; 1067 $EXTCMD{$name} = $cb;
1068}
1069
1070sub register_exticmd {
1071 my ($name, $cb) = @_;
1072
1073 $EXTICMD{$name} = $cb;
878} 1074}
879 1075
880cf::player->attach ( 1076cf::player->attach (
881 on_command => sub { 1077 on_command => sub {
882 my ($pl, $name, $params) = @_; 1078 my ($pl, $name, $params) = @_;
… …
907 1103
908 cf::override; 1104 cf::override;
909 }, 1105 },
910); 1106);
911 1107
912sub load_extension {
913 my ($path) = @_;
914
915 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
916 my $base = $1;
917 my $pkg = $1;
918 $pkg =~ s/[^[:word:]]/_/g;
919 $pkg = "ext::$pkg";
920
921 warn "... loading '$path' into '$pkg'\n";
922
923 open my $fh, "<:utf8", $path
924 or die "$path: $!";
925
926 my $source =
927 "package $pkg; use strict; use utf8;\n"
928 . "#line 1 \"$path\"\n{\n"
929 . (do { local $/; <$fh> })
930 . "\n};\n1";
931
932 unless (eval $source) {
933 my $msg = $@ ? "$path: $@\n"
934 : "extension disabled.\n";
935 if ($source =~ /^#!.*perl.*#.*MANDATORY/m) { # ugly match
936 warn $@;
937 warn "mandatory extension failed to load, exiting.\n";
938 exit 1;
939 }
940 die $@;
941 }
942
943 push @EXTS, $pkg;
944}
945
946sub load_extensions { 1108sub load_extensions {
1109 cf::sync_job {
1110 my %todo;
1111
947 for my $ext (<$LIBDIR/*.ext>) { 1112 for my $path (<$LIBDIR/*.ext>) {
948 next unless -r $ext; 1113 next unless -r $path;
949 eval { 1114
950 load_extension $ext; 1115 $path =~ /([^\/\\]+)\.ext$/ or die "$path";
1116 my $base = $1;
1117 my $pkg = $1;
1118 $pkg =~ s/[^[:word:]]/_/g;
1119 $pkg = "ext::$pkg";
1120
1121 open my $fh, "<:utf8", $path
1122 or die "$path: $!";
1123
1124 my $source = do { local $/; <$fh> };
1125
1126 my %ext = (
1127 path => $path,
1128 base => $base,
1129 pkg => $pkg,
1130 );
1131
1132 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1133 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1134
1135 $ext{source} =
1136 "package $pkg; use strict; use utf8;\n"
1137 . "#line 1 \"$path\"\n{\n"
1138 . $source
1139 . "\n};\n1";
1140
1141 $todo{$base} = \%ext;
1142 }
1143
1144 my %done;
1145 while (%todo) {
1146 my $progress;
1147
1148 while (my ($k, $v) = each %todo) {
1149 for (split /,\s*/, $v->{meta}{depends}) {
1150 goto skip
1151 unless exists $done{$_};
1152 }
1153
1154 warn "... loading '$k' into '$v->{pkg}'\n";
1155
1156 unless (eval $v->{source}) {
1157 my $msg = $@ ? "$v->{path}: $@\n"
1158 : "$v->{base}: extension inactive.\n";
1159
1160 if (exists $v->{meta}{mandatory}) {
1161 warn $msg;
1162 warn "mandatory extension failed to load, exiting.\n";
1163 exit 1;
1164 }
1165
1166 warn $msg;
1167 }
1168
1169 $done{$k} = delete $todo{$k};
1170 push @EXTS, $v->{pkg};
1171 $progress = 1;
951 1 1172 }
952 } or warn "$ext not loaded: $@"; 1173
1174 skip:
1175 die "cannot load " . (join ", ", keys %todo) . ": unable to resolve dependencies\n"
1176 unless $progress;
1177 }
953 } 1178 };
954} 1179}
955 1180
956############################################################################# 1181#############################################################################
1182
1183=back
957 1184
958=head2 CORE EXTENSIONS 1185=head2 CORE EXTENSIONS
959 1186
960Functions and methods that extend core crossfire objects. 1187Functions and methods that extend core crossfire objects.
961 1188
… …
1149 } 1376 }
1150 1377
1151 \@paths 1378 \@paths
1152} 1379}
1153 1380
1381=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1382
1383Expand crossfire pod fragments into protocol xml.
1384
1385=cut
1386
1387sub expand_cfpod {
1388 ((my $self), (local $_)) = @_;
1389
1390 # escape & and <
1391 s/&/&amp;/g;
1392 s/(?<![BIUGH])</&lt;/g;
1393
1394 # this is buggy, it needs to properly take care of nested <'s
1395
1396 1 while
1397 # replace B<>, I<>, U<> etc.
1398 s/B<([^\>]*)>/<b>$1<\/b>/
1399 || s/I<([^\>]*)>/<i>$1<\/i>/
1400 || s/U<([^\>]*)>/<u>$1<\/u>/
1401 # replace G<male|female> tags
1402 || s{G<([^>|]*)\|([^>]*)>}{
1403 $self->gender ? $2 : $1
1404 }ge
1405 # replace H<hint text>
1406 || s/H<([^\>]*)>/<fg name="lightblue">[$1]<\/fg>/g;
1407
1408 # create single paragraphs (very hackish)
1409 s/(?<=\S)\n(?=\w)/ /g;
1410
1411 $_
1412}
1413
1154=item $player->ext_reply ($msgid, %msg) 1414=item $player->ext_reply ($msgid, %msg)
1155 1415
1156Sends an ext reply to the player. 1416Sends an ext reply to the player.
1157 1417
1158=cut 1418=cut
1159 1419
1160sub ext_reply($$%) { 1420sub ext_reply($$%) {
1161 my ($self, $id, %msg) = @_; 1421 my ($self, $id, %msg) = @_;
1162 1422
1163 $msg{msgid} = $id; 1423 $msg{msgid} = $id;
1164
1165 $self->send ("ext " . cf::to_json \%msg); 1424 $self->send ("ext " . cf::to_json \%msg);
1166} 1425}
1167 1426
1168=item $player->ext_event ($type, %msg) 1427=item $player->ext_event ($type, %msg)
1169 1428
… …
1185 1444
1186package cf::region; 1445package cf::region;
1187 1446
1188=item cf::region::find_by_path $path 1447=item cf::region::find_by_path $path
1189 1448
1190Tries to decuce the probable region for a map knowing only its path. 1449Tries to decuce the likely region for a map knowing only its path.
1191 1450
1192=cut 1451=cut
1193 1452
1194sub find_by_path($) { 1453sub find_by_path($) {
1195 my ($path) = @_; 1454 my ($path) = @_;
… …
1269 my ($self, $merge) = @_; 1528 my ($self, $merge) = @_;
1270 1529
1271 # we have to keep some variables in memory intact 1530 # we have to keep some variables in memory intact
1272 local $self->{path}; 1531 local $self->{path};
1273 local $self->{load_path}; 1532 local $self->{load_path};
1274 local $self->{deny_save};
1275 local $self->{deny_reset};
1276 1533
1277 $self->SUPER::thawer_merge ($merge); 1534 $self->SUPER::thawer_merge ($merge);
1278} 1535}
1279 1536
1280sub normalise { 1537sub normalise {
… …
1380 1637
1381 $_->change_map_light ($change) 1638 $_->change_map_light ($change)
1382 for grep $_->outdoor, values %cf::MAP; 1639 for grep $_->outdoor, values %cf::MAP;
1383} 1640}
1384 1641
1642sub decay_objects {
1643 my ($self) = @_;
1644
1645 return if $self->{deny_reset};
1646
1647 $self->do_decay_objects;
1648}
1649
1385sub unlink_save { 1650sub unlink_save {
1386 my ($self) = @_; 1651 my ($self) = @_;
1387 1652
1388 utf8::encode (my $save = $self->save_path); 1653 utf8::encode (my $save = $self->save_path);
1389 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1654 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
… …
1445 $self->load_header_orig 1710 $self->load_header_orig
1446 or return; 1711 or return;
1447 $self->prepare_orig; 1712 $self->prepare_orig;
1448 } 1713 }
1449 1714
1715 $self->{deny_reset} = 1
1716 if $self->no_reset;
1717
1450 $self->default_region (cf::region::find_by_path $self->{path}) 1718 $self->default_region (cf::region::find_by_path $self->{path})
1451 unless $self->default_region; 1719 unless $self->default_region;
1452 1720
1453 1 1721 1
1454} 1722}
… …
1469 $map->{last_save} = $cf::RUNTIME; 1737 $map->{last_save} = $cf::RUNTIME;
1470 1738
1471 $map->load_header 1739 $map->load_header
1472 or return; 1740 or return;
1473 1741
1474 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?) 1742 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1475 # doing this can freeze the server in a sync job, obviously 1743 # doing this can freeze the server in a sync job, obviously
1476 #$cf::WAIT_FOR_TICK->wait; 1744 #$cf::WAIT_FOR_TICK->wait;
1477 $map->reset; 1745 $map->reset;
1478 undef $guard; 1746 undef $guard;
1479 return find $path; 1747 return find $path;
… …
1546 my ($self, $ob) = @_; 1814 my ($self, $ob) = @_;
1547 1815
1548 return find "~" . $ob->name . "/" . $self->{path} 1816 return find "~" . $ob->name . "/" . $self->{path}
1549 if $self->per_player; 1817 if $self->per_player;
1550 1818
1819# return find "?party/" . $ob->name . "/" . $self->{path}
1820# if $self->per_party;
1821
1551 $self 1822 $self
1552} 1823}
1553 1824
1554# find and load all maps in the 3x3 area around a map 1825# find and load all maps in the 3x3 area around a map
1555sub load_diag { 1826sub load_diag {
… …
1665 1936
1666sub reset_at { 1937sub reset_at {
1667 my ($self) = @_; 1938 my ($self) = @_;
1668 1939
1669 # TODO: safety, remove and allow resettable per-player maps 1940 # TODO: safety, remove and allow resettable per-player maps
1670 return 1e99 if $self->isa ("ext::map_per_player");#d#
1671 return 1e99 if $self->{deny_reset}; 1941 return 1e99 if $self->{deny_reset};
1672 1942
1673 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access; 1943 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1674 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET; 1944 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1675 1945
… …
1686 my ($self) = @_; 1956 my ($self) = @_;
1687 1957
1688 my $lock = cf::lock_acquire "map_data:$self->{path}"; 1958 my $lock = cf::lock_acquire "map_data:$self->{path}";
1689 1959
1690 return if $self->players; 1960 return if $self->players;
1691 return if $self->isa ("ext::map_per_player");#d#
1692 1961
1693 warn "resetting map ", $self->path;#d# 1962 warn "resetting map ", $self->path;
1694 1963
1695 $self->in_memory (cf::MAP_SWAPPED); 1964 $self->in_memory (cf::MAP_SWAPPED);
1696 1965
1697 # need to save uniques path 1966 # need to save uniques path
1698 unless ($self->{deny_save}) { 1967 unless ($self->{deny_save}) {
… …
1730 $cf::MAP{$self->path} = $self; 1999 $cf::MAP{$self->path} = $self;
1731 2000
1732 $self->reset; # polite request, might not happen 2001 $self->reset; # polite request, might not happen
1733} 2002}
1734 2003
2004=item $maps = cf::map::tmp_maps
2005
2006Returns an arrayref with all map paths of currently instantiated and saved
2007maps. May block.
2008
2009=cut
2010
2011sub tmp_maps() {
2012 [
2013 map {
2014 utf8::decode $_;
2015 /\.map$/
2016 ? normalise $_
2017 : ()
2018 } @{ aio_readdir $TMPDIR or [] }
2019 ]
2020}
2021
2022=item $maps = cf::map::random_maps
2023
2024Returns an arrayref with all map paths of currently instantiated and saved
2025random maps. May block.
2026
2027=cut
2028
2029sub random_maps() {
2030 [
2031 map {
2032 utf8::decode $_;
2033 /\.map$/
2034 ? normalise "?random/$_"
2035 : ()
2036 } @{ aio_readdir $RANDOMDIR or [] }
2037 ]
2038}
2039
1735=item cf::map::unique_maps 2040=item cf::map::unique_maps
1736 2041
1737Returns an arrayref of paths of all shared maps that have 2042Returns an arrayref of paths of all shared maps that have
1738instantiated unique items. May block. 2043instantiated unique items. May block.
1739 2044
1740=cut 2045=cut
1741 2046
1742sub unique_maps() { 2047sub unique_maps() {
1743 my $files = aio_readdir $UNIQUEDIR 2048 [
1744 or return; 2049 map {
1745
1746 my @paths;
1747
1748 for (@$files) {
1749 utf8::decode $_; 2050 utf8::decode $_;
1750 next if /\.pst$/; 2051 /\.map$/
1751 next unless /^$PATH_SEP/o; 2052 ? normalise $_
1752 2053 : ()
1753 push @paths, cf::map::normalise $_; 2054 } @{ aio_readdir $UNIQUEDIR or [] }
1754 } 2055 ]
1755
1756 \@paths
1757} 2056}
1758 2057
1759package cf; 2058package cf;
1760 2059
1761=back 2060=back
… …
1807 2106
1808 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2107 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
1809 2108
1810 if ($self->{record_replies}) { 2109 if ($self->{record_replies}) {
1811 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2110 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2111
1812 } else { 2112 } else {
2113 my $pl = $self->contr;
2114
2115 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2116 my $diag = $pl->{npc_dialog};
2117 $diag->{pl}->ext_reply (
2118 $diag->{id},
2119 msgtype => "reply",
2120 msg => $diag->{pl}->expand_cfpod ($msg),
2121 add_topics => []
2122 );
2123
2124 } else {
1813 $msg = $npc->name . " says: $msg" if $npc; 2125 $msg = $npc->name . " says: $msg" if $npc;
1814 $self->message ($msg, $flags); 2126 $self->message ($msg, $flags);
2127 }
1815 } 2128 }
1816} 2129}
1817 2130
1818=item $player_object->may ("access") 2131=item $player_object->may ("access")
1819 2132
… …
1867 $self->deactivate_recursive; 2180 $self->deactivate_recursive;
1868 2181
1869 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2182 return if UNIVERSAL::isa $self->map, "ext::map_link";
1870 2183
1871 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2184 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1872 if $self->map; 2185 if $self->map && $self->map->{path} ne "{link}";
1873 2186
1874 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2187 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1875} 2188}
1876 2189
1877sub cf::object::player::leave_link { 2190sub cf::object::player::leave_link {
1878 my ($self, $map, $x, $y) = @_; 2191 my ($self, $map, $x, $y) = @_;
2192
2193 return unless $self->contr->active;
1879 2194
1880 my $link_pos = delete $self->{_link_pos}; 2195 my $link_pos = delete $self->{_link_pos};
1881 2196
1882 unless ($map) { 2197 unless ($map) {
1883 # restore original map position 2198 # restore original map position
… …
1906 2221
1907 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2222 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1908 $self->enter_map ($map, $x, $y); 2223 $self->enter_map ($map, $x, $y);
1909} 2224}
1910 2225
1911cf::player->attach (
1912 on_logout => sub {
1913 my ($pl) = @_;
1914
1915 # abort map switching before logout
1916 if ($pl->ob->{_link_pos}) {
1917 cf::sync_job {
1918 $pl->ob->leave_link
1919 };
1920 }
1921 },
1922 on_login => sub {
1923 my ($pl) = @_;
1924
1925 # try to abort aborted map switching on player login :)
1926 # should happen only on crashes
1927 if ($pl->ob->{_link_pos}) {
1928 $pl->ob->enter_link;
1929 (async {
1930 $pl->ob->reply (undef,
1931 "There was an internal problem at your last logout, "
1932 . "the server will try to bring you to your intended destination in a second.",
1933 cf::NDI_RED);
1934 # we need this sleep as the login has a concurrent enter_exit running
1935 # and this sleep increases chances of the player not ending up in scorn
1936 Coro::Timer::sleep 1;
1937 $pl->ob->leave_link;
1938 })->prio (2);
1939 }
1940 },
1941);
1942
1943=item $player_object->goto ($path, $x, $y) 2226=item $player_object->goto ($path, $x, $y[, $check->($map)])
1944 2227
2228Moves the player to the given map-path and coordinates by first freezing
2229her, loading and preparing them map, calling the provided $check callback
2230that has to return the map if sucecssful, and then unfreezes the player on
2231the new (success) or old (failed) map position.
2232
1945=cut 2233=cut
2234
2235our $GOTOGEN;
1946 2236
1947sub cf::object::player::goto { 2237sub cf::object::player::goto {
1948 my ($self, $path, $x, $y) = @_; 2238 my ($self, $path, $x, $y, $check) = @_;
2239
2240 # do generation counting so two concurrent goto's will be executed in-order
2241 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
1949 2242
1950 $self->enter_link; 2243 $self->enter_link;
1951 2244
1952 (async { 2245 (async {
1953 my $map = eval { 2246 my $map = eval {
1954 my $map = cf::map::find $path; 2247 my $map = cf::map::find $path;
2248
2249 if ($map) {
1955 $map = $map->customise_for ($self) if $map; 2250 $map = $map->customise_for ($self);
2251 $map = $check->($map) if $check && $map;
2252 } else {
2253 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2254 }
2255
1956 $map 2256 $map
2257 };
2258
2259 if ($@) {
2260 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2261 LOG llevError | logBacktrace, Carp::longmess $@;
1957 } or 2262 }
1958 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1959 2263
2264 if ($gen == $self->{_goto_generation}) {
2265 delete $self->{_goto_generation};
1960 $self->leave_link ($map, $x, $y); 2266 $self->leave_link ($map, $x, $y);
2267 }
1961 })->prio (1); 2268 })->prio (1);
1962} 2269}
1963 2270
1964=item $player_object->enter_exit ($exit_object) 2271=item $player_object->enter_exit ($exit_object)
1965 2272
… …
2070 2377
2071 utf8::encode $text; 2378 utf8::encode $text;
2072 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2379 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2073} 2380}
2074 2381
2382=item $client->send_msg ($color, $type, $msg, [extra...])
2383
2384Send a drawinfo or msg packet to the client, formatting the msg for the
2385client if neccessary. C<$type> should be a string identifying the type of
2386the message, with C<log> being the default. If C<$color> is negative, suppress
2387the message unless the client supports the msg packet.
2388
2389=cut
2390
2391sub cf::client::send_msg {
2392 my ($self, $color, $type, $msg, @extra) = @_;
2393
2394 $msg = $self->pl->expand_cfpod ($msg);
2395
2396 if ($self->can_msg) {
2397 $self->send_packet ("msg " . cf::to_json [$color, $type, $msg, @extra]);
2398 } else {
2399 # replace some tags by gcfclient-compatible ones
2400 for ($msg) {
2401 1 while
2402 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2403 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2404 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2405 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2406 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2407 }
2408
2409 if ($color >= 0) {
2410 if (0 && $msg =~ /\[/) {
2411 $self->send_packet ("drawextinfo $color 4 0 $msg")
2412 } else {
2413 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2414 $self->send_packet ("drawinfo $color $msg")
2415 }
2416 }
2417 }
2418}
2419
2075=item $client->ext_event ($type, %msg) 2420=item $client->ext_event ($type, %msg)
2076 2421
2077Sends an exti event to the client. 2422Sends an ext event to the client.
2078 2423
2079=cut 2424=cut
2080 2425
2081sub cf::client::ext_event($$%) { 2426sub cf::client::ext_event($$%) {
2082 my ($self, $type, %msg) = @_; 2427 my ($self, $type, %msg) = @_;
… …
2089 2434
2090Queues a query to the client, calling the given callback with 2435Queues a query to the client, calling the given callback with
2091the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2436the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2092C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2437C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2093 2438
2094Queries can fail, so check the return code. Or don't, as queries will become 2439Queries can fail, so check the return code. Or don't, as queries will
2095reliable at some point in the future. 2440become reliable at some point in the future.
2096 2441
2097=cut 2442=cut
2098 2443
2099sub cf::client::query { 2444sub cf::client::query {
2100 my ($self, $flags, $text, $cb) = @_; 2445 my ($self, $flags, $text, $cb) = @_;
… …
2108 utf8::encode $text; 2453 utf8::encode $text;
2109 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2454 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2110 2455
2111 $self->send_packet ($self->{query_queue}[0][0]) 2456 $self->send_packet ($self->{query_queue}[0][0])
2112 if @{ $self->{query_queue} } == 1; 2457 if @{ $self->{query_queue} } == 1;
2458
2459 1
2113} 2460}
2114 2461
2115cf::client->attach ( 2462cf::client->attach (
2116 on_reply => sub { 2463 on_reply => sub {
2117 my ($ns, $msg) = @_; 2464 my ($ns, $msg) = @_;
… …
2131 $ns->send_packet ($ns->{query_queue}[0][0]); 2478 $ns->send_packet ($ns->{query_queue}[0][0]);
2132 } else { 2479 } else {
2133 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2480 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2134 } 2481 }
2135 } 2482 }
2483 },
2484 on_exticmd => sub {
2485 my ($ns, $buf) = @_;
2486
2487 my $msg = eval { from_json $buf };
2488
2489 if (ref $msg) {
2490 if (my $cb = $EXTICMD{$msg->{msgtype}}) {
2491 if (my %reply = $cb->($ns, $msg)) {
2492 $reply{msgid} = $msg->{msgid};
2493 $ns->send ("ext " . cf::to_json \%reply);
2494 }
2495 }
2496 } else {
2497 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2498 }
2499
2500 cf::override;
2136 }, 2501 },
2137); 2502);
2138 2503
2139=item $client->async (\&cb) 2504=item $client->async (\&cb)
2140 2505
… …
2279=back 2644=back
2280 2645
2281=cut 2646=cut
2282 2647
2283############################################################################# 2648#############################################################################
2284
2285=head2 EXTENSION DATABASE SUPPORT
2286
2287Crossfire maintains a very simple database for extension use. It can
2288currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2289convert to/from binary).
2290
2291The parameter C<$family> should best start with the name of the extension
2292using it, it should be unique.
2293
2294=over 4
2295
2296=item $value = cf::db_get $family => $key
2297
2298Returns a single value from the database.
2299
2300=item cf::db_put $family => $key => $value
2301
2302Stores the given C<$value> in the family.
2303
2304=cut
2305
2306our $DB;
2307
2308sub db_init {
2309 unless ($DB) {
2310 $DB = BDB::db_create $DB_ENV;
2311
2312 cf::sync_job {
2313 eval {
2314 $DB->set_flags (BDB::CHKSUM);
2315
2316 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2317 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2318 cf::cleanup "db_open(db): $!" if $!;
2319 };
2320 cf::cleanup "db_open(db): $@" if $@;
2321 };
2322 }
2323}
2324
2325sub db_get($$) {
2326 my $key = "$_[0]/$_[1]";
2327
2328 cf::sync_job {
2329 BDB::db_get $DB, undef, $key, my $data;
2330
2331 $! ? ()
2332 : $data
2333 }
2334}
2335
2336sub db_put($$$) {
2337 BDB::dbreq_pri 4;
2338 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2339}
2340
2341=item cf::cache $id => [$paths...], $processversion => $process
2342
2343Generic caching function that returns the value of the resource $id,
2344caching and regenerating as required.
2345
2346This function can block.
2347
2348=cut
2349
2350sub cache {
2351 my ($id, $src, $processversion, $process) = @_;
2352
2353 my $meta =
2354 join "\x00",
2355 $processversion,
2356 map {
2357 aio_stat $_
2358 and Carp::croak "$_: $!";
2359
2360 ($_, (stat _)[7,9])
2361 } @$src;
2362
2363 my $dbmeta = db_get cache => "$id/meta";
2364 if ($dbmeta ne $meta) {
2365 # changed, we may need to process
2366
2367 my @data;
2368 my $md5;
2369
2370 for (0 .. $#$src) {
2371 0 <= aio_load $src->[$_], $data[$_]
2372 or Carp::croak "$src->[$_]: $!";
2373 }
2374
2375 # if processing is expensive, check
2376 # checksum first
2377 if (1) {
2378 $md5 =
2379 join "\x00",
2380 $processversion,
2381 map {
2382 Coro::cede;
2383 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2384 } 0.. $#$src;
2385
2386
2387 my $dbmd5 = db_get cache => "$id/md5";
2388 if ($dbmd5 eq $md5) {
2389 db_put cache => "$id/meta", $meta;
2390
2391 return db_get cache => "$id/data";
2392 }
2393 }
2394
2395 my $t1 = Time::HiRes::time;
2396 my $data = $process->(\@data);
2397 my $t2 = Time::HiRes::time;
2398
2399 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2400
2401 db_put cache => "$id/data", $data;
2402 db_put cache => "$id/md5" , $md5;
2403 db_put cache => "$id/meta", $meta;
2404
2405 return $data;
2406 }
2407
2408 db_get cache => "$id/data"
2409}
2410
2411=item fork_call { }, $args
2412
2413Executes the given code block with the given arguments in a seperate
2414process, returning the results. Everything must be serialisable with
2415Coro::Storable. May, of course, block. Note that the executed sub may
2416never block itself or use any form of Event handling.
2417
2418=cut
2419
2420sub fork_call(&@) {
2421 my ($cb, @args) = @_;
2422
2423# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2424# or die "socketpair: $!";
2425 pipe my $fh1, my $fh2
2426 or die "pipe: $!";
2427
2428 if (my $pid = fork) {
2429 close $fh2;
2430
2431 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2432 $res = Coro::Storable::thaw $res;
2433
2434 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2435
2436 die $$res unless "ARRAY" eq ref $res;
2437
2438 return wantarray ? @$res : $res->[-1];
2439 } else {
2440 local $SIG{__WARN__};
2441 eval {
2442 local $SIG{__DIE__};
2443 close $fh1;
2444
2445 my @res = eval { $cb->(@args) };
2446 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2447 };
2448
2449 warn $@ if $@;
2450 _exit 0;
2451 }
2452}
2453
2454
2455
2456#############################################################################
2457# the server's init and main functions 2649# the server's init and main functions
2458 2650
2459sub load_facedata($) { 2651sub load_facedata($) {
2460 my ($path) = @_; 2652 my ($path) = @_;
2461 2653
… …
2531sub reload_resources { 2723sub reload_resources {
2532 warn "reloading resource files...\n"; 2724 warn "reloading resource files...\n";
2533 2725
2534 reload_regions; 2726 reload_regions;
2535 reload_facedata; 2727 reload_facedata;
2728 #reload_archetypes;#d#
2536 reload_archetypes; 2729 reload_archetypes;
2537 reload_treasures; 2730 reload_treasures;
2538 2731
2539 warn "finished reloading resource files\n"; 2732 warn "finished reloading resource files\n";
2540} 2733}
… …
2597 }, 2790 },
2598 ); 2791 );
2599 } 2792 }
2600} 2793}
2601 2794
2795sub write_runtime {
2796 my $runtime = "$LOCALDIR/runtime";
2797
2798 # first touch the runtime file to show we are still running:
2799 # the fsync below can take a very very long time.
2800
2801 IO::AIO::aio_utime $runtime, undef, undef;
2802
2803 my $guard = cf::lock_acquire "write_runtime";
2804
2805 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
2806 or return;
2807
2808 my $value = $cf::RUNTIME + 90 + 10;
2809 # 10 is the runtime save interval, for a monotonic clock
2810 # 60 allows for the watchdog to kill the server.
2811
2812 (aio_write $fh, 0, (length $value), $value, 0) <= 0
2813 and return;
2814
2815 # always fsync - this file is important
2816 aio_fsync $fh
2817 and return;
2818
2819 # touch it again to show we are up-to-date
2820 aio_utime $fh, undef, undef;
2821
2822 close $fh
2823 or return;
2824
2825 aio_rename "$runtime~", $runtime
2826 and return;
2827
2828 warn "runtime file written.\n";
2829
2830 1
2831}
2832
2602sub emergency_save() { 2833sub emergency_save() {
2603 my $freeze_guard = cf::freeze_mainloop; 2834 my $freeze_guard = cf::freeze_mainloop;
2604 2835
2605 warn "enter emergency perl save\n"; 2836 warn "enter emergency perl save\n";
2606 2837
… …
2681 %EXT_CORO = (); 2912 %EXT_CORO = ();
2682 2913
2683 warn "removing commands"; 2914 warn "removing commands";
2684 %COMMAND = (); 2915 %COMMAND = ();
2685 2916
2686 warn "removing ext commands"; 2917 warn "removing ext/exti commands";
2687 %EXTCMD = (); 2918 %EXTCMD = ();
2919 %EXTICMD = ();
2688 2920
2689 warn "unloading/nuking all extensions"; 2921 warn "unloading/nuking all extensions";
2690 for my $pkg (@EXTS) { 2922 for my $pkg (@EXTS) {
2691 warn "... unloading $pkg"; 2923 warn "... unloading $pkg";
2692 2924
… …
2810 my $signal = new Coro::Signal; 3042 my $signal = new Coro::Signal;
2811 push @WAIT_FOR_TICK_BEGIN, $signal; 3043 push @WAIT_FOR_TICK_BEGIN, $signal;
2812 $signal->wait; 3044 $signal->wait;
2813} 3045}
2814 3046
3047 my $min = 1e6;#d#
3048 my $avg = 10;
2815$TICK_WATCHER = Event->timer ( 3049$TICK_WATCHER = Event->timer (
2816 reentrant => 0, 3050 reentrant => 0,
2817 parked => 1, 3051 parked => 1,
2818 prio => 0, 3052 prio => 0,
2819 at => $NEXT_TICK || $TICK, 3053 at => $NEXT_TICK || $TICK,
… …
2823 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3057 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2824 unless ++$bug_warning > 10; 3058 unless ++$bug_warning > 10;
2825 return; 3059 return;
2826 } 3060 }
2827 3061
2828 $NOW = Event::time; 3062 $NOW = $tick_start = Event::time;
2829 3063
2830 cf::server_tick; # one server iteration 3064 cf::server_tick; # one server iteration
3065
3066 0 && sync_job {#d#
3067 for(1..10) {
3068 my $t = Event::time;
3069 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3070 or die;
3071
3072 $map->width (50);
3073 $map->height (50);
3074 $map->alloc;
3075 $map->_load_objects ("/tmp/x.map", 1);
3076 my $t = Event::time - $t;
3077
3078 #next unless $t < 0.0013;#d#
3079 if ($t < $min) {
3080 $min = $t;
3081 }
3082 $avg = $avg * 0.99 + $t * 0.01;
3083 }
3084 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3085 exit 0;
3086 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3087 };
2831 3088
2832 $RUNTIME += $TICK; 3089 $RUNTIME += $TICK;
2833 $NEXT_TICK += $TICK; 3090 $NEXT_TICK += $TICK;
2834 3091
2835 if ($NOW >= $NEXT_RUNTIME_WRITE) { 3092 if ($NOW >= $NEXT_RUNTIME_WRITE) {
… …
2841 } 3098 }
2842 3099
2843# my $AFTER = Event::time; 3100# my $AFTER = Event::time;
2844# warn $AFTER - $NOW;#d# 3101# warn $AFTER - $NOW;#d#
2845 3102
3103 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3104 $sig->send;
3105 }
3106 while (my $sig = shift @WAIT_FOR_TICK) {
3107 $sig->send;
3108 }
3109
3110 $NOW = Event::time;
3111
2846 # if we are delayed by four ticks or more, skip them all 3112 # if we are delayed by four ticks or more, skip them all
2847 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 3113 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2848 3114
2849 $TICK_WATCHER->at ($NEXT_TICK); 3115 $TICK_WATCHER->at ($NEXT_TICK);
2850 $TICK_WATCHER->start; 3116 $TICK_WATCHER->start;
2851 3117
2852 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3118 $LOAD = ($NOW - $tick_start) / $TICK;
2853 $sig->send; 3119 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2854 }
2855 while (my $sig = shift @WAIT_FOR_TICK) {
2856 $sig->send;
2857 }
2858 3120
2859 _post_tick; 3121 _post_tick;
3122
3123
2860 }, 3124 },
2861); 3125);
2862 3126
2863{ 3127{
2864 BDB::max_poll_time $TICK * 0.1; 3128 BDB::max_poll_time $TICK * 0.1;
… …
2923 prio => 6, 3187 prio => 6,
2924 cb => \&IO::AIO::poll_cb, 3188 cb => \&IO::AIO::poll_cb,
2925 ); 3189 );
2926} 3190}
2927 3191
3192my $_log_backtrace;
3193
2928sub _log_backtrace { 3194sub _log_backtrace {
2929 my ($msg, @addr) = @_; 3195 my ($msg, @addr) = @_;
2930 3196
3197 $msg =~ s/\n//;
3198
3199 # limit the # of concurrent backtraces
3200 if ($_log_backtrace < 2) {
3201 ++$_log_backtrace;
2931 async { 3202 async {
2932 my @bt = fork_call { 3203 my @bt = fork_call {
2933 @addr = map { sprintf "%x", $_ } @addr; 3204 @addr = map { sprintf "%x", $_ } @addr;
3205 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
2934 open my $fh, "exec addr2line -C -f -i -e \Q$^X\E @addr 2>&1 |" 3206 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
2935 or die "addr2line: $!"; 3207 or die "addr2line: $!";
2936 3208
2937 my @funcs; 3209 my @funcs;
2938 my @res = <$fh>; 3210 my @res = <$fh>;
2939 chomp for @res; 3211 chomp for @res;
2940 while (@res) { 3212 while (@res) {
2941 my ($func, $line) = splice @res, 0, 2, (); 3213 my ($func, $line) = splice @res, 0, 2, ();
2942 push @funcs, "[$func] $line"; 3214 push @funcs, "[$func] $line";
3215 }
3216
3217 @funcs
2943 } 3218 };
2944 3219
2945 @funcs 3220 LOG llevInfo, "[ABT] $msg\n";
3221 LOG llevInfo, "[ABT] $_\n" for @bt;
3222 --$_log_backtrace;
2946 }; 3223 };
2947 3224 } else {
2948 $msg =~ s/\n//;
2949
2950 LOG llevInfo, "[ABT] $msg\n"; 3225 LOG llevInfo, "[ABT] $msg\n";
2951 LOG llevInfo, "[ABT] $_\n" for @bt; 3226 LOG llevInfo, "[ABT] [suppressed]\n";
2952 }; 3227 }
2953} 3228}
2954 3229
2955# load additional modules 3230# load additional modules
2956use cf::pod; 3231use cf::pod;
2957 3232

Diff Legend

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