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.281 by root, Sat Jun 16 23:22:59 2007 UTC vs.
Revision 1.363 by root, Mon Sep 10 17:24:36 2007 UTC

… …
10use Event; 10use Event;
11use Opcode; 11use Opcode;
12use Safe; 12use Safe;
13use Safe::Hole; 13use Safe::Hole;
14 14
15use Coro 3.61 (); 15use Coro 3.64 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::Event;
19use Coro::Timer; 19use Coro::Timer;
20use Coro::Signal; 20use Coro::Signal;
21use Coro::Semaphore; 21use Coro::Semaphore;
22use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable; 23use Coro::Storable;
24use Coro::Util ();
24 25
26use JSON::XS ();
25use BDB (); 27use BDB ();
26use Data::Dumper; 28use Data::Dumper;
27use Digest::MD5; 29use Digest::MD5;
28use Fcntl; 30use Fcntl;
29use YAML::Syck (); 31use YAML::Syck ();
30use IO::AIO 2.32 (); 32use IO::AIO 2.32 ();
31use Time::HiRes; 33use Time::HiRes;
32use Compress::LZF; 34use Compress::LZF;
35use Digest::MD5 ();
33 36
34# configure various modules to our taste 37# configure various modules to our taste
35# 38#
36$Storable::canonical = 1; # reduce rsync transfers 39$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
… …
49our %COMMAND = (); 52our %COMMAND = ();
50our %COMMAND_TIME = (); 53our %COMMAND_TIME = ();
51 54
52our @EXTS = (); # list of extension package names 55our @EXTS = (); # list of extension package names
53our %EXTCMD = (); 56our %EXTCMD = ();
57our %EXTICMD = ();
54our %EXT_CORO = (); # coroutines bound to extensions 58our %EXT_CORO = (); # coroutines bound to extensions
55our %EXT_MAP = (); # pluggable maps 59our %EXT_MAP = (); # pluggable maps
56 60
57our $RELOAD; # number of reloads so far 61our $RELOAD; # number of reloads so far
58our @EVENT; 62our @EVENT;
… …
76our $NEXT_TICK; 80our $NEXT_TICK;
77our $NOW; 81our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off 82our $USE_FSYNC = 1; # use fsync to write maps - default off
79 83
80our $BDB_POLL_WATCHER; 84our $BDB_POLL_WATCHER;
85our $BDB_CHECKPOINT_WATCHER;
86our $BDB_TRICKLE_WATCHER;
81our $DB_ENV; 87our $DB_ENV;
82 88
83our %CFG; 89our %CFG;
84 90
85our $UPTIME; $UPTIME ||= time; 91our $UPTIME; $UPTIME ||= time;
86our $RUNTIME; 92our $RUNTIME;
87 93
88our %PLAYER; # all users 94our (%PLAYER, %PLAYER_LOADING); # all users
89our %MAP; # all maps 95our (%MAP, %MAP_LOADING ); # all maps
90our $LINK_MAP; # the special {link} map, which is always available 96our $LINK_MAP; # the special {link} map, which is always available
91 97
92# used to convert map paths into valid unix filenames by replacing / by ∕ 98# used to convert map paths into valid unix filenames by replacing / by ∕
93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 99our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
94 100
… …
164 170
165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 171These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
166returns directly I<after> the tick processing (and consequently, can only wake one process 172returns directly I<after> the tick processing (and consequently, can only wake one process
167per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 173per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
168 174
175=item @cf::INVOKE_RESULTS
176
177This array contains the results of the last C<invoke ()> call. When
178C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
179that call.
180
169=back 181=back
170 182
171=cut 183=cut
172 184
173BEGIN { 185BEGIN {
… …
177 $msg .= "\n" 189 $msg .= "\n"
178 unless $msg =~ /\n$/; 190 unless $msg =~ /\n$/;
179 191
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 192 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181 193
182 utf8::encode $msg;
183 LOG llevError, $msg; 194 LOG llevError, $msg;
184 }; 195 };
185} 196}
186 197
187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 198@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
236 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 247 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
237 $d 248 $d
238 } || "[unable to dump $_[0]: '$@']"; 249 } || "[unable to dump $_[0]: '$@']";
239} 250}
240 251
241use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
242
243=item $ref = cf::from_json $json 252=item $ref = cf::from_json $json
244 253
245Converts a JSON string into the corresponding perl data structure. 254Converts a JSON string into the corresponding perl data structure.
246 255
247=item $json = cf::to_json $ref 256=item $json = cf::to_json $ref
248 257
249Converts a perl data structure into its JSON representation. 258Converts a perl data structure into its JSON representation.
259
260=cut
261
262our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
263
264sub to_json ($) { $json_coder->encode ($_[0]) }
265sub from_json ($) { $json_coder->decode ($_[0]) }
250 266
251=item cf::lock_wait $string 267=item cf::lock_wait $string
252 268
253Wait until the given lock is available. See cf::lock_acquire. 269Wait until the given lock is available. See cf::lock_acquire.
254 270
… …
257Wait until the given lock is available and then acquires it and returns 273Wait until the given lock is available and then acquires it and returns
258a Coro::guard object. If the guard object gets destroyed (goes out of scope, 274a Coro::guard object. If the guard object gets destroyed (goes out of scope,
259for example when the coroutine gets canceled), the lock is automatically 275for example when the coroutine gets canceled), the lock is automatically
260returned. 276returned.
261 277
278Locks are *not* recursive, locking from the same coro twice results in a
279deadlocked coro.
280
262Lock names should begin with a unique identifier (for example, cf::map::find 281Lock names should begin with a unique identifier (for example, cf::map::find
263uses map_find and cf::map::load uses map_load). 282uses map_find and cf::map::load uses map_load).
264 283
265=item $locked = cf::lock_active $string 284=item $locked = cf::lock_active $string
266 285
267Return true if the lock is currently active, i.e. somebody has locked it. 286Return true if the lock is currently active, i.e. somebody has locked it.
268 287
269=cut 288=cut
270 289
271our %LOCK; 290our %LOCK;
291our %LOCKER;#d#
272 292
273sub lock_wait($) { 293sub lock_wait($) {
274 my ($key) = @_; 294 my ($key) = @_;
295
296 if ($LOCKER{$key} == $Coro::current) {#d#
297 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
298 return;#d#
299 }#d#
275 300
276 # wait for lock, if any 301 # wait for lock, if any
277 while ($LOCK{$key}) { 302 while ($LOCK{$key}) {
278 push @{ $LOCK{$key} }, $Coro::current; 303 push @{ $LOCK{$key} }, $Coro::current;
279 Coro::schedule; 304 Coro::schedule;
… …
285 310
286 # wait, to be sure we are not locked 311 # wait, to be sure we are not locked
287 lock_wait $key; 312 lock_wait $key;
288 313
289 $LOCK{$key} = []; 314 $LOCK{$key} = [];
315 $LOCKER{$key} = $Coro::current;#d#
290 316
291 Coro::guard { 317 Coro::guard {
318 delete $LOCKER{$key};#d#
292 # wake up all waiters, to be on the safe side 319 # wake up all waiters, to be on the safe side
293 $_->ready for @{ delete $LOCK{$key} }; 320 $_->ready for @{ delete $LOCK{$key} };
294 } 321 }
295} 322}
296 323
… …
306 my $guard = Coro::guard { 333 my $guard = Coro::guard {
307 $TICK_WATCHER->start; 334 $TICK_WATCHER->start;
308 }; 335 };
309 $TICK_WATCHER->stop; 336 $TICK_WATCHER->stop;
310 $guard 337 $guard
338}
339
340=item cf::get_slot $time[, $priority[, $name]]
341
342Allocate $time seconds of blocking CPU time at priority C<$priority>:
343This call blocks and returns only when you have at least C<$time> seconds
344of cpu time till the next tick. The slot is only valid till the next cede.
345
346The optional C<$name> can be used to identify the job to run. It might be
347used for statistical purposes and should identify the same time-class.
348
349Useful for short background jobs.
350
351=cut
352
353our @SLOT_QUEUE;
354our $SLOT_QUEUE;
355
356$SLOT_QUEUE->cancel if $SLOT_QUEUE;
357$SLOT_QUEUE = Coro::async {
358 my $signal = new Coro::Signal;
359
360 while () {
361 next_job:
362 my $avail = cf::till_tick;
363 if ($avail > 0.01) {
364 for (0 .. $#SLOT_QUEUE) {
365 if ($SLOT_QUEUE[$_][0] < $avail) {
366 my $job = splice @SLOT_QUEUE, $_, 1, ();
367 $job->[2]->send;
368 Coro::cede;
369 goto next_job;
370 }
371 }
372 }
373
374 if (@SLOT_QUEUE) {
375 # we do not use wait_For_tick() as it returns immediately when tick is inactive
376 push @cf::WAIT_FOR_TICK, $signal;
377 $signal->wait;
378 } else {
379 Coro::schedule;
380 }
381 }
382};
383
384sub get_slot($;$$) {
385 my ($time, $pri, $name) = @_;
386
387 $time = $TICK * .6 if $time > $TICK * .6;
388 my $sig = new Coro::Signal;
389
390 push @SLOT_QUEUE, [$time, $pri, $sig, $name];
391 @SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
392 $SLOT_QUEUE->ready;
393 $sig->wait;
311} 394}
312 395
313=item cf::async { BLOCK } 396=item cf::async { BLOCK }
314 397
315Currently the same as Coro::async_pool, meaning you cannot use 398Currently the same as Coro::async_pool, meaning you cannot use
… …
405=cut 488=cut
406 489
407sub fork_call(&@) { 490sub fork_call(&@) {
408 my ($cb, @args) = @_; 491 my ($cb, @args) = @_;
409 492
410# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC 493 # we seemingly have to make a local copy of the whole thing,
411# or die "socketpair: $!"; 494 # otherwise perl prematurely frees the stuff :/
412 pipe my $fh1, my $fh2 495 # TODO: investigate and fix (likely this will be rather laborious)
413 or die "pipe: $!";
414 496
415 if (my $pid = fork) { 497 my @res = Coro::Util::fork_eval {
416 close $fh2;
417
418 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
419 $res = Coro::Storable::thaw $res;
420
421 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
422
423 die $$res unless "ARRAY" eq ref $res;
424
425 return wantarray ? @$res : $res->[-1];
426 } else {
427 reset_signals; 498 reset_signals;
428 local $SIG{__WARN__}; 499 &$cb
429 local $SIG{__DIE__}; 500 }, @args;
430 eval {
431 close $fh1;
432 501
433 my @res = eval { $cb->(@args) }; 502 wantarray ? @res : $res[-1]
434 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
435 };
436
437 warn $@ if $@;
438 _exit 0;
439 }
440} 503}
441 504
442=item $value = cf::db_get $family => $key 505=item $value = cf::db_get $family => $key
443 506
444Returns a single value from the environment database. 507Returns a single value from the environment database.
… …
446=item cf::db_put $family => $key => $value 509=item cf::db_put $family => $key => $value
447 510
448Stores the given C<$value> in the family. It can currently store binary 511Stores the given C<$value> in the family. It can currently store binary
449data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 512data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
450 513
514=item $db = cf::db_table "name"
515
516Create and/or open a new database table. The string must not be "db" and must be unique
517within each server.
518
451=cut 519=cut
520
521sub db_table($) {
522 my ($name) = @_;
523 my $db = BDB::db_create $DB_ENV;
524
525 eval {
526 $db->set_flags (BDB::CHKSUM);
527
528 utf8::encode $name;
529 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
530 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
531 cf::cleanup "db_open(db): $!" if $!;
532 };
533 cf::cleanup "db_open(db): $@" if $@;
534
535 $db
536}
452 537
453our $DB; 538our $DB;
454 539
455sub db_init { 540sub db_init {
456 unless ($DB) {
457 $DB = BDB::db_create $DB_ENV;
458
459 cf::sync_job { 541 cf::sync_job {
460 eval { 542 $DB ||= db_table "db";
461 $DB->set_flags (BDB::CHKSUM);
462
463 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
464 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
465 cf::cleanup "db_open(db): $!" if $!;
466 };
467 cf::cleanup "db_open(db): $@" if $@;
468 };
469 } 543 };
470} 544}
471 545
472sub db_get($$) { 546sub db_get($$) {
473 my $key = "$_[0]/$_[1]"; 547 my $key = "$_[0]/$_[1]";
474 548
… …
524 if (1) { 598 if (1) {
525 $md5 = 599 $md5 =
526 join "\x00", 600 join "\x00",
527 $processversion, 601 $processversion,
528 map { 602 map {
529 Coro::cede; 603 cf::cede_to_tick;
530 ($src->[$_], Digest::MD5::md5_hex $data[$_]) 604 ($src->[$_], Digest::MD5::md5_hex $data[$_])
531 } 0.. $#$src; 605 } 0.. $#$src;
532 606
533 607
534 my $dbmd5 = db_get cache => "$id/md5"; 608 my $dbmd5 = db_get cache => "$id/md5";
… …
840 "; 914 ";
841 die if $@; 915 die if $@;
842} 916}
843 917
844our $override; 918our $override;
845our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals? 919our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
846 920
847sub override { 921sub override {
848 $override = 1; 922 $override = 1;
849 @invoke_results = (); 923 @INVOKE_RESULTS = (@_);
850} 924}
851 925
852sub do_invoke { 926sub do_invoke {
853 my $event = shift; 927 my $event = shift;
854 my $callbacks = shift; 928 my $callbacks = shift;
855 929
856 @invoke_results = (); 930 @INVOKE_RESULTS = ();
857 931
858 local $override; 932 local $override;
859 933
860 for (@$callbacks) { 934 for (@$callbacks) {
861 eval { &{$_->[1]} }; 935 eval { &{$_->[1]} };
… …
878 952
879Generate an object-specific event with the given arguments. 953Generate an object-specific event with the given arguments.
880 954
881This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be 955This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
882removed in future versions), and there is no public API to access override 956removed in future versions), and there is no public API to access override
883results (if you must, access C<@cf::invoke_results> directly). 957results (if you must, access C<@cf::INVOKE_RESULTS> directly).
884 958
885=back 959=back
886 960
887=cut 961=cut
888 962
889############################################################################# 963#############################################################################
890# object support 964# object support
965#
966
967sub _can_merge {
968 my ($ob1, $ob2) = @_;
969
970 local $Storable::canonical = 1;
971 my $fob1 = Storable::freeze $ob1;
972 my $fob2 = Storable::freeze $ob2;
973
974 $fob1 eq $fob2
975}
891 976
892sub reattach { 977sub reattach {
893 # basically do the same as instantiate, without calling instantiate 978 # basically do the same as instantiate, without calling instantiate
894 my ($obj) = @_; 979 my ($obj) = @_;
895 980
… …
940); 1025);
941 1026
942sub object_freezer_save { 1027sub object_freezer_save {
943 my ($filename, $rdata, $objs) = @_; 1028 my ($filename, $rdata, $objs) = @_;
944 1029
1030 my $guard = cf::lock_acquire "io";
1031
945 sync_job { 1032 sync_job {
946 if (length $$rdata) { 1033 if (length $$rdata) {
1034 utf8::decode (my $decname = $filename);
947 warn sprintf "saving %s (%d,%d)\n", 1035 warn sprintf "saving %s (%d,%d)\n",
948 $filename, length $$rdata, scalar @$objs; 1036 $decname, length $$rdata, scalar @$objs;
949 1037
950 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1038 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
951 chmod SAVE_MODE, $fh; 1039 chmod SAVE_MODE, $fh;
952 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1040 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
953 aio_fsync $fh if $cf::USE_FSYNC; 1041 aio_fsync $fh if $cf::USE_FSYNC;
… …
972 } 1060 }
973 } else { 1061 } else {
974 aio_unlink $filename; 1062 aio_unlink $filename;
975 aio_unlink "$filename.pst"; 1063 aio_unlink "$filename.pst";
976 } 1064 }
977 } 1065 };
1066
1067 undef $guard;
978} 1068}
979 1069
980sub object_freezer_as_string { 1070sub object_freezer_as_string {
981 my ($rdata, $objs) = @_; 1071 my ($rdata, $objs) = @_;
982 1072
… …
987 1077
988sub object_thawer_load { 1078sub object_thawer_load {
989 my ($filename) = @_; 1079 my ($filename) = @_;
990 1080
991 my ($data, $av); 1081 my ($data, $av);
1082
1083 my $guard = cf::lock_acquire "io";
992 1084
993 (aio_load $filename, $data) >= 0 1085 (aio_load $filename, $data) >= 0
994 or return; 1086 or return;
995 1087
996 unless (aio_stat "$filename.pst") { 1088 unless (aio_stat "$filename.pst") {
997 (aio_load "$filename.pst", $av) >= 0 1089 (aio_load "$filename.pst", $av) >= 0
998 or return; 1090 or return;
1091
1092 undef $guard;
999 $av = eval { (Storable::thaw $av)->{objs} }; 1093 $av = eval { (Storable::thaw $av)->{objs} };
1000 } 1094 }
1001 1095
1096 utf8::decode (my $decname = $filename);
1002 warn sprintf "loading %s (%d)\n", 1097 warn sprintf "loading %s (%d,%d)\n",
1003 $filename, length $data, scalar @{$av || []}; 1098 $decname, length $data, scalar @{$av || []};
1099
1004 return ($data, $av); 1100 ($data, $av)
1005} 1101}
1006 1102
1007=head2 COMMAND CALLBACKS 1103=head2 COMMAND CALLBACKS
1008 1104
1009=over 4 1105=over 4
… …
1029 push @{ $COMMAND{$name} }, [$caller, $cb]; 1125 push @{ $COMMAND{$name} }, [$caller, $cb];
1030} 1126}
1031 1127
1032=item cf::register_extcmd $name => \&callback($pl,$packet); 1128=item cf::register_extcmd $name => \&callback($pl,$packet);
1033 1129
1034Register a callback fro execution when the client sends an extcmd packet. 1130Register a callback for execution when the client sends an (synchronous)
1131extcmd packet. Ext commands will be processed in the order they are
1132received by the server, like other user commands. The first argument is
1133the logged-in player. Ext commands can only be processed after a player
1134has logged in successfully.
1035 1135
1036If the callback returns something, it is sent back as if reply was being 1136If the callback returns something, it is sent back as if reply was being
1037called. 1137called.
1038 1138
1139=item cf::register_exticmd $name => \&callback($ns,$packet);
1140
1141Register a callback for execution when the client sends an (asynchronous)
1142exticmd packet. Exti commands are processed by the server as soon as they
1143are received, i.e. out of order w.r.t. other commands. The first argument
1144is a client socket. Exti commands can be received anytime, even before
1145log-in.
1146
1147If the callback returns something, it is sent back as if reply was being
1148called.
1149
1039=cut 1150=cut
1040 1151
1041sub register_extcmd { 1152sub register_extcmd {
1042 my ($name, $cb) = @_; 1153 my ($name, $cb) = @_;
1043 1154
1044 $EXTCMD{$name} = $cb; 1155 $EXTCMD{$name} = $cb;
1156}
1157
1158sub register_exticmd {
1159 my ($name, $cb) = @_;
1160
1161 $EXTICMD{$name} = $cb;
1045} 1162}
1046 1163
1047cf::player->attach ( 1164cf::player->attach (
1048 on_command => sub { 1165 on_command => sub {
1049 my ($pl, $name, $params) = @_; 1166 my ($pl, $name, $params) = @_;
… …
1058 cf::override; 1175 cf::override;
1059 }, 1176 },
1060 on_extcmd => sub { 1177 on_extcmd => sub {
1061 my ($pl, $buf) = @_; 1178 my ($pl, $buf) = @_;
1062 1179
1063 my $msg = eval { from_json $buf }; 1180 my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1064 1181
1065 if (ref $msg) { 1182 if (ref $msg) {
1183 my ($type, $reply, @payload) =
1184 "ARRAY" eq ref $msg
1185 ? @$msg
1186 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
1187
1188 my @reply;
1189
1066 if (my $cb = $EXTCMD{$msg->{msgtype}}) { 1190 if (my $cb = $EXTCMD{$type}) {
1067 if (my %reply = $cb->($pl, $msg)) { 1191 @reply = $cb->($pl, @payload);
1068 $pl->ext_reply ($msg->{msgid}, %reply);
1069 }
1070 } 1192 }
1193
1194 $pl->ext_reply ($reply, @reply)
1195 if $reply;
1196
1071 } else { 1197 } else {
1072 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1198 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1073 } 1199 }
1074 1200
1075 cf::override; 1201 cf::override;
… …
1165 1291
1166=head3 cf::player 1292=head3 cf::player
1167 1293
1168=over 4 1294=over 4
1169 1295
1296=item cf::player::num_playing
1297
1298Returns the official number of playing players, as per the Crossfire metaserver rules.
1299
1300=cut
1301
1302sub num_playing {
1303 scalar grep
1304 $_->ob->map
1305 && !$_->hidden
1306 && !$_->ob->flag (cf::FLAG_WIZ),
1307 cf::player::list
1308}
1309
1170=item cf::player::find $login 1310=item cf::player::find $login
1171 1311
1172Returns the given player object, loading it if necessary (might block). 1312Returns the given player object, loading it if necessary (might block).
1173 1313
1174=cut 1314=cut
… …
1209 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1349 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1210 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1350 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1211 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1351 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1212 aio_unlink +(playerdir $login) . "/$login.pl"; 1352 aio_unlink +(playerdir $login) . "/$login.pl";
1213 1353
1214 my $pl = load_pl path $login 1354 my $f = new_from_file cf::object::thawer path $login
1215 or return; 1355 or return;
1356
1357 $f->next;
1358 my $pl = cf::player::load_pl $f
1359 or return;
1360 local $cf::PLAYER_LOADING{$login} = $pl;
1361 $f->resolve_delayed_derefs;
1216 $cf::PLAYER{$login} = $pl 1362 $cf::PLAYER{$login} = $pl
1217 } 1363 }
1218 } 1364 }
1219} 1365}
1220 1366
… …
1230 1376
1231 aio_mkdir playerdir $pl, 0770; 1377 aio_mkdir playerdir $pl, 0770;
1232 $pl->{last_save} = $cf::RUNTIME; 1378 $pl->{last_save} = $cf::RUNTIME;
1233 1379
1234 $pl->save_pl ($path); 1380 $pl->save_pl ($path);
1235 Coro::cede; 1381 cf::cede_to_tick;
1236} 1382}
1237 1383
1238sub new($) { 1384sub new($) {
1239 my ($login) = @_; 1385 my ($login) = @_;
1240 1386
… …
1244 $self->{deny_save} = 1; 1390 $self->{deny_save} = 1;
1245 1391
1246 $cf::PLAYER{$login} = $self; 1392 $cf::PLAYER{$login} = $self;
1247 1393
1248 $self 1394 $self
1395}
1396
1397=item $player->send_msg ($channel, $msg, $color, [extra...])
1398
1399=cut
1400
1401sub send_msg {
1402 my $ns = shift->ns
1403 or return;
1404 $ns->send_msg (@_);
1249} 1405}
1250 1406
1251=item $pl->quit_character 1407=item $pl->quit_character
1252 1408
1253Nukes the player without looking back. If logged in, the connection will 1409Nukes the player without looking back. If logged in, the connection will
… …
1308 or return []; 1464 or return [];
1309 1465
1310 my @logins; 1466 my @logins;
1311 1467
1312 for my $login (@$dirs) { 1468 for my $login (@$dirs) {
1469 my $path = path $login;
1470
1471 # a .pst is a dead give-away for a valid player
1472 unless (-e "$path.pst") {
1313 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next; 1473 my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1314 aio_read $fh, 0, 512, my $buf, 0 or next; 1474 aio_read $fh, 0, 512, my $buf, 0 or next;
1315 $buf !~ /^password -------------$/m or next; # official not-valid tag 1475 $buf !~ /^password -------------$/m or next; # official not-valid tag
1476 }
1316 1477
1317 utf8::decode $login; 1478 utf8::decode $login;
1318 push @logins, $login; 1479 push @logins, $login;
1319 } 1480 }
1320 1481
… …
1347 } 1508 }
1348 1509
1349 \@paths 1510 \@paths
1350} 1511}
1351 1512
1513=item $protocol_xml = $player->expand_cfpod ($crossfire_pod)
1514
1515Expand crossfire pod fragments into protocol xml.
1516
1517=cut
1518
1519sub expand_cfpod {
1520 ((my $self), (local $_)) = @_;
1521
1522 # escape & and <
1523 s/&/&amp;/g;
1524 s/(?<![BIUGHT])</&lt;/g;
1525
1526 # this is buggy, it needs to properly take care of nested <'s
1527
1528 1 while
1529 # replace B<>, I<>, U<> etc.
1530 s/B<([^\>]*)>/<b>$1<\/b>/
1531 || s/I<([^\>]*)>/<i>$1<\/i>/
1532 || s/U<([^\>]*)>/<u>$1<\/u>/
1533 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1534 # replace G<male|female> tags
1535 || s{G<([^>|]*)\|([^>]*)>}{
1536 $self->gender ? $2 : $1
1537 }ge
1538 # replace H<hint text>
1539 || s{H<([^\>]*)>}
1540 {
1541 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>",
1542 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1543 "")
1544 [$self->{hintmode}]
1545 }ge;
1546
1547 # create single paragraphs (very hackish)
1548 s/(?<=\S)\n(?=\w)/ /g;
1549
1550 # compress some whitespace
1551 s/\s+\n/\n/g; # ws line-ends
1552 s/\n\n+/\n/g; # double lines
1553 s/^\n+//; # beginning lines
1554 s/\n+$//; # ending lines
1555
1556 $_
1557}
1558
1559sub hintmode {
1560 $_[0]{hintmode} = $_[1] if @_ > 1;
1561 $_[0]{hintmode}
1562}
1563
1352=item $player->ext_reply ($msgid, %msg) 1564=item $player->ext_reply ($msgid, @msg)
1353 1565
1354Sends an ext reply to the player. 1566Sends an ext reply to the player.
1355 1567
1356=cut 1568=cut
1357 1569
1358sub ext_reply($$%) { 1570sub ext_reply($$@) {
1359 my ($self, $id, %msg) = @_; 1571 my ($self, $id, @msg) = @_;
1360 1572
1361 $msg{msgid} = $id; 1573 $self->ns->ext_reply ($id, @msg)
1362
1363 $self->send ("ext " . cf::to_json \%msg);
1364} 1574}
1365 1575
1366=item $player->ext_event ($type, %msg) 1576=item $player->ext_msg ($type, @msg)
1367 1577
1368Sends an ext event to the client. 1578Sends an ext event to the client.
1369 1579
1370=cut 1580=cut
1371 1581
1372sub ext_event($$%) { 1582sub ext_msg($$@) {
1373 my ($self, $type, %msg) = @_; 1583 my ($self, $type, @msg) = @_;
1374 1584
1375 $self->ns->ext_event ($type, %msg); 1585 $self->ns->ext_msg ($type, @msg);
1376} 1586}
1377 1587
1378=head3 cf::region 1588=head3 cf::region
1379 1589
1380=over 4 1590=over 4
… …
1393 my ($path) = @_; 1603 my ($path) = @_;
1394 1604
1395 my ($match, $specificity); 1605 my ($match, $specificity);
1396 1606
1397 for my $region (list) { 1607 for my $region (list) {
1398 if ($region->match && $path =~ $region->match) { 1608 if ($region->{match} && $path =~ $region->{match}) {
1399 ($match, $specificity) = ($region, $region->specificity) 1609 ($match, $specificity) = ($region, $region->specificity)
1400 if $region->specificity > $specificity; 1610 if $region->specificity > $specificity;
1401 } 1611 }
1402 } 1612 }
1403 1613
… …
1523 $self->init; # pass $1 etc. 1733 $self->init; # pass $1 etc.
1524 return $self; 1734 return $self;
1525 } 1735 }
1526 } 1736 }
1527 1737
1528 Carp::carp "unable to resolve path '$path' (base '$base')."; 1738 Carp::cluck "unable to resolve path '$path' (base '$base').";
1529 () 1739 ()
1530} 1740}
1531 1741
1532sub init { 1742sub init {
1533 my ($self) = @_; 1743 my ($self) = @_;
… …
1596 1806
1597sub load_header_from($) { 1807sub load_header_from($) {
1598 my ($self, $path) = @_; 1808 my ($self, $path) = @_;
1599 1809
1600 utf8::encode $path; 1810 utf8::encode $path;
1601 #aio_open $path, O_RDONLY, 0 1811 my $f = new_from_file cf::object::thawer $path
1602 # or return;
1603
1604 $self->_load_header ($path)
1605 or return; 1812 or return;
1813
1814 $self->_load_header ($f)
1815 or return;
1816
1817 local $MAP_LOADING{$self->{path}} = $self;
1818 $f->resolve_delayed_derefs;
1606 1819
1607 $self->{load_path} = $path; 1820 $self->{load_path} = $path;
1608 1821
1609 1 1822 1
1610} 1823}
… …
1664sub find { 1877sub find {
1665 my ($path, $origin) = @_; 1878 my ($path, $origin) = @_;
1666 1879
1667 $path = normalise $path, $origin && $origin->path; 1880 $path = normalise $path, $origin && $origin->path;
1668 1881
1882 cf::lock_wait "map_data:$path";#d#remove
1669 cf::lock_wait "map_find:$path"; 1883 cf::lock_wait "map_find:$path";
1670 1884
1671 $cf::MAP{$path} || do { 1885 $cf::MAP{$path} || do {
1672 my $guard = cf::lock_acquire "map_find:$path"; 1886 my $guard1 = cf::lock_acquire "map_find:$path";
1887 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1888
1673 my $map = new_from_path cf::map $path 1889 my $map = new_from_path cf::map $path
1674 or return; 1890 or return;
1675 1891
1676 $map->{last_save} = $cf::RUNTIME; 1892 $map->{last_save} = $cf::RUNTIME;
1677 1893
… …
1679 or return; 1895 or return;
1680 1896
1681 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1897 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1682 # doing this can freeze the server in a sync job, obviously 1898 # doing this can freeze the server in a sync job, obviously
1683 #$cf::WAIT_FOR_TICK->wait; 1899 #$cf::WAIT_FOR_TICK->wait;
1900 undef $guard1;
1901 undef $guard2;
1684 $map->reset; 1902 $map->reset;
1685 undef $guard;
1686 return find $path; 1903 return find $path;
1687 } 1904 }
1688 1905
1689 $cf::MAP{$path} = $map 1906 $cf::MAP{$path} = $map
1690 } 1907 }
… …
1699 local $self->{deny_reset} = 1; # loading can take a long time 1916 local $self->{deny_reset} = 1; # loading can take a long time
1700 1917
1701 my $path = $self->{path}; 1918 my $path = $self->{path};
1702 1919
1703 { 1920 {
1704 my $guard = cf::lock_acquire "map_load:$path"; 1921 my $guard = cf::lock_acquire "map_data:$path";
1705 1922
1923 return unless $self->valid;
1706 return if $self->in_memory != cf::MAP_SWAPPED; 1924 return unless $self->in_memory == cf::MAP_SWAPPED;
1707 1925
1708 $self->in_memory (cf::MAP_LOADING); 1926 $self->in_memory (cf::MAP_LOADING);
1709 1927
1710 $self->alloc; 1928 $self->alloc;
1711 1929
1712 $self->pre_load; 1930 $self->pre_load;
1713 Coro::cede; 1931 cf::cede_to_tick;
1714 1932
1933 my $f = new_from_file cf::object::thawer $self->{load_path};
1934 $f->skip_block;
1715 $self->_load_objects ($self->{load_path}, 1) 1935 $self->_load_objects ($f)
1716 or return; 1936 or return;
1717 1937
1718 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1938 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1719 if delete $self->{load_original}; 1939 if delete $self->{load_original};
1720 1940
1721 if (my $uniq = $self->uniq_path) { 1941 if (my $uniq = $self->uniq_path) {
1722 utf8::encode $uniq; 1942 utf8::encode $uniq;
1723 if (aio_open $uniq, O_RDONLY, 0) { 1943 unless (aio_stat $uniq) {
1944 if (my $f = new_from_file cf::object::thawer $uniq) {
1724 $self->clear_unique_items; 1945 $self->clear_unique_items;
1725 $self->_load_objects ($uniq, 0); 1946 $self->_load_objects ($f);
1947 $f->resolve_delayed_derefs;
1948 }
1726 } 1949 }
1727 } 1950 }
1728 1951
1729 Coro::cede; 1952 $f->resolve_delayed_derefs;
1953
1954 cf::cede_to_tick;
1730 # now do the right thing for maps 1955 # now do the right thing for maps
1731 $self->link_multipart_objects; 1956 $self->link_multipart_objects;
1732 $self->difficulty ($self->estimate_difficulty) 1957 $self->difficulty ($self->estimate_difficulty)
1733 unless $self->difficulty; 1958 unless $self->difficulty;
1734 Coro::cede; 1959 cf::cede_to_tick;
1735 1960
1736 unless ($self->{deny_activate}) { 1961 unless ($self->{deny_activate}) {
1737 $self->decay_objects; 1962 $self->decay_objects;
1738 $self->fix_auto_apply; 1963 $self->fix_auto_apply;
1739 $self->update_buttons; 1964 $self->update_buttons;
1740 Coro::cede; 1965 cf::cede_to_tick;
1741 $self->set_darkness_map; 1966 $self->set_darkness_map;
1742 Coro::cede; 1967 cf::cede_to_tick;
1743 $self->activate; 1968 $self->activate;
1744 } 1969 }
1970
1971 $self->{last_save} = $cf::RUNTIME;
1972 $self->last_access ($cf::RUNTIME);
1745 1973
1746 $self->in_memory (cf::MAP_IN_MEMORY); 1974 $self->in_memory (cf::MAP_IN_MEMORY);
1747 } 1975 }
1748 1976
1749 $self->post_load; 1977 $self->post_load;
… …
1760 1988
1761 $self 1989 $self
1762} 1990}
1763 1991
1764# find and load all maps in the 3x3 area around a map 1992# find and load all maps in the 3x3 area around a map
1765sub load_diag { 1993sub load_neighbours {
1766 my ($map) = @_; 1994 my ($map) = @_;
1767 1995
1768 my @diag; # diagonal neighbours 1996 my @neigh; # diagonal neighbours
1769 1997
1770 for (0 .. 3) { 1998 for (0 .. 3) {
1771 my $neigh = $map->tile_path ($_) 1999 my $neigh = $map->tile_path ($_)
1772 or next; 2000 or next;
1773 $neigh = find $neigh, $map 2001 $neigh = find $neigh, $map
1774 or next; 2002 or next;
1775 $neigh->load; 2003 $neigh->load;
1776 2004
2005 push @neigh,
1777 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh], 2006 [$neigh->tile_path (($_ + 3) % 4), $neigh],
1778 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2007 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1779 } 2008 }
1780 2009
1781 for (@diag) { 2010 for (grep defined $_->[0], @neigh) {
2011 my ($path, $origin) = @$_;
1782 my $neigh = find @$_ 2012 my $neigh = find $path, $origin
1783 or next; 2013 or next;
1784 $neigh->load; 2014 $neigh->load;
1785 } 2015 }
1786} 2016}
1787 2017
… …
1792} 2022}
1793 2023
1794sub do_load_sync { 2024sub do_load_sync {
1795 my ($map) = @_; 2025 my ($map) = @_;
1796 2026
2027 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync"
2028 if $Coro::current == $Coro::main;
2029
1797 cf::sync_job { $map->load }; 2030 cf::sync_job { $map->load };
1798} 2031}
1799 2032
1800our %MAP_PREFETCH; 2033our %MAP_PREFETCH;
1801our $MAP_PREFETCHER = undef; 2034our $MAP_PREFETCHER = undef;
1802 2035
1803sub find_async { 2036sub find_async {
1804 my ($path, $origin) = @_; 2037 my ($path, $origin, $load) = @_;
1805 2038
1806 $path = normalise $path, $origin && $origin->{path}; 2039 $path = normalise $path, $origin && $origin->{path};
1807 2040
1808 if (my $map = $cf::MAP{$path}) { 2041 if (my $map = $cf::MAP{$path}) {
1809 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 2042 return $map if !$load || $map->in_memory == cf::MAP_IN_MEMORY;
1810 } 2043 }
1811 2044
1812 undef $MAP_PREFETCH{$path}; 2045 $MAP_PREFETCH{$path} |= $load;
2046
1813 $MAP_PREFETCHER ||= cf::async { 2047 $MAP_PREFETCHER ||= cf::async {
1814 while (%MAP_PREFETCH) { 2048 while (%MAP_PREFETCH) {
1815 for my $path (keys %MAP_PREFETCH) { 2049 while (my ($k, $v) = each %MAP_PREFETCH) {
1816 my $map = find $path 2050 if (my $map = find $k) {
1817 or next;
1818 $map->load; 2051 $map->load if $v;
2052 }
1819 2053
1820 delete $MAP_PREFETCH{$path}; 2054 delete $MAP_PREFETCH{$k};
1821 } 2055 }
1822 } 2056 }
1823 undef $MAP_PREFETCHER; 2057 undef $MAP_PREFETCHER;
1824 }; 2058 };
1825 $MAP_PREFETCHER->prio (6); 2059 $MAP_PREFETCHER->prio (6);
… …
1828} 2062}
1829 2063
1830sub save { 2064sub save {
1831 my ($self) = @_; 2065 my ($self) = @_;
1832 2066
1833 my $lock = cf::lock_acquire "map_data:" . $self->path; 2067 my $lock = cf::lock_acquire "map_data:$self->{path}";
1834 2068
1835 $self->{last_save} = $cf::RUNTIME; 2069 $self->{last_save} = $cf::RUNTIME;
1836 2070
1837 return unless $self->dirty; 2071 return unless $self->dirty;
1838 2072
… …
1861 my ($self) = @_; 2095 my ($self) = @_;
1862 2096
1863 # save first because save cedes 2097 # save first because save cedes
1864 $self->save; 2098 $self->save;
1865 2099
1866 my $lock = cf::lock_acquire "map_data:" . $self->path; 2100 my $lock = cf::lock_acquire "map_data:$self->{path}";
1867 2101
1868 return if $self->players; 2102 return if $self->players;
1869 return if $self->in_memory != cf::MAP_IN_MEMORY; 2103 return if $self->in_memory != cf::MAP_IN_MEMORY;
1870 return if $self->{deny_save}; 2104 return if $self->{deny_save};
1871 2105
2106 $self->in_memory (cf::MAP_SWAPPED);
2107
2108 $self->deactivate;
2109 $_->clear_links_to ($self) for values %cf::MAP;
1872 $self->clear; 2110 $self->clear;
1873 $self->in_memory (cf::MAP_SWAPPED);
1874} 2111}
1875 2112
1876sub reset_at { 2113sub reset_at {
1877 my ($self) = @_; 2114 my ($self) = @_;
1878 2115
… …
1910 if $uniq; 2147 if $uniq;
1911 } 2148 }
1912 2149
1913 delete $cf::MAP{$self->path}; 2150 delete $cf::MAP{$self->path};
1914 2151
2152 $self->deactivate;
2153 $_->clear_links_to ($self) for values %cf::MAP;
1915 $self->clear; 2154 $self->clear;
1916
1917 $_->clear_links_to ($self) for values %cf::MAP;
1918 2155
1919 $self->unlink_save; 2156 $self->unlink_save;
1920 $self->destroy; 2157 $self->destroy;
1921} 2158}
1922 2159
1923my $nuke_counter = "aaaa"; 2160my $nuke_counter = "aaaa";
1924 2161
1925sub nuke { 2162sub nuke {
1926 my ($self) = @_; 2163 my ($self) = @_;
1927 2164
2165 {
2166 my $lock = cf::lock_acquire "map_data:$self->{path}";
2167
1928 delete $cf::MAP{$self->path}; 2168 delete $cf::MAP{$self->path};
1929 2169
1930 $self->unlink_save; 2170 $self->unlink_save;
1931 2171
1932 bless $self, "cf::map"; 2172 bless $self, "cf::map";
1933 delete $self->{deny_reset}; 2173 delete $self->{deny_reset};
1934 $self->{deny_save} = 1; 2174 $self->{deny_save} = 1;
1935 $self->reset_timeout (1); 2175 $self->reset_timeout (1);
1936 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2176 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
1937 2177
1938 $cf::MAP{$self->path} = $self; 2178 $cf::MAP{$self->path} = $self;
2179 }
1939 2180
1940 $self->reset; # polite request, might not happen 2181 $self->reset; # polite request, might not happen
1941} 2182}
1942 2183
1943=item $maps = cf::map::tmp_maps 2184=item $maps = cf::map::tmp_maps
… …
2019 2260
2020sub inv_recursive { 2261sub inv_recursive {
2021 inv_recursive_ inv $_[0] 2262 inv_recursive_ inv $_[0]
2022} 2263}
2023 2264
2265=item $ref = $ob->ref
2266
2267creates and returns a persistent reference to an objetc that can be stored as a string.
2268
2269=item $ob = cf::object::deref ($refstring)
2270
2271returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2272even if the object actually exists. May block.
2273
2274=cut
2275
2276sub deref {
2277 my ($ref) = @_;
2278
2279 # temporary compatibility#TODO#remove
2280 $ref =~ s{^<}{player/<};
2281
2282 if ($ref =~ m{^player\/(<1\.\d+>)/(.*)$}) {
2283 my ($uuid, $name) = ($1, $2);
2284 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2285 or return;
2286 $pl->ob->uuid eq $uuid
2287 or return;
2288
2289 $pl->ob
2290 } else {
2291 warn "$ref: cannot resolve object reference\n";
2292 undef
2293 }
2294}
2295
2024package cf; 2296package cf;
2025 2297
2026=back 2298=back
2027 2299
2028=head3 cf::object::player 2300=head3 cf::object::player
… …
2045 2317
2046 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4; 2318 $flags = cf::NDI_BROWN | cf::NDI_UNIQUE unless @_ >= 4;
2047 2319
2048 if ($self->{record_replies}) { 2320 if ($self->{record_replies}) {
2049 push @{ $self->{record_replies} }, [$npc, $msg, $flags]; 2321 push @{ $self->{record_replies} }, [$npc, $msg, $flags];
2322
2050 } else { 2323 } else {
2324 my $pl = $self->contr;
2325
2326 if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2327 my $dialog = $pl->{npc_dialog};
2328 $dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2329
2330 } else {
2051 $msg = $npc->name . " says: $msg" if $npc; 2331 $msg = $npc->name . " says: $msg" if $npc;
2052 $self->message ($msg, $flags); 2332 $self->message ($msg, $flags);
2333 }
2053 } 2334 }
2335}
2336
2337=item $object->send_msg ($channel, $msg, $color, [extra...])
2338
2339=cut
2340
2341sub cf::object::send_msg {
2342 my $pl = shift->contr
2343 or return;
2344 $pl->send_msg (@_);
2054} 2345}
2055 2346
2056=item $player_object->may ("access") 2347=item $player_object->may ("access")
2057 2348
2058Returns wether the given player is authorized to access resource "access" 2349Returns wether the given player is authorized to access resource "access"
… …
2137 # use -1 or undef as default coordinates, not 0, 0 2428 # use -1 or undef as default coordinates, not 0, 0
2138 ($x, $y) = ($map->enter_x, $map->enter_y) 2429 ($x, $y) = ($map->enter_x, $map->enter_y)
2139 if $x <=0 && $y <= 0; 2430 if $x <=0 && $y <= 0;
2140 2431
2141 $map->load; 2432 $map->load;
2142 $map->load_diag; 2433 $map->load_neighbours;
2143 2434
2144 return unless $self->contr->active; 2435 return unless $self->contr->active;
2145 $self->activate_recursive; 2436 $self->activate_recursive;
2146 2437
2147 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2438 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2148 $self->enter_map ($map, $x, $y); 2439 $self->enter_map ($map, $x, $y);
2149} 2440}
2150 2441
2151=item $player_object->goto ($path, $x, $y[, $check->($map)]) 2442=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]])
2152 2443
2153Moves the player to the given map-path and coordinates by first freezing 2444Moves the player to the given map-path and coordinates by first freezing
2154her, loading and preparing them map, calling the provided $check callback 2445her, loading and preparing them map, calling the provided $check callback
2155that has to return the map if sucecssful, and then unfreezes the player on 2446that has to return the map if sucecssful, and then unfreezes the player on
2156the new (success) or old (failed) map position. 2447the new (success) or old (failed) map position. In either case, $done will
2448be called at the end of this process.
2157 2449
2158=cut 2450=cut
2159 2451
2160our $GOTOGEN; 2452our $GOTOGEN;
2161 2453
2162sub cf::object::player::goto { 2454sub cf::object::player::goto {
2163 my ($self, $path, $x, $y, $check) = @_; 2455 my ($self, $path, $x, $y, $check, $done) = @_;
2164 2456
2165 # do generation counting so two concurrent goto's will be executed in-order 2457 # do generation counting so two concurrent goto's will be executed in-order
2166 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2458 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2167 2459
2168 $self->enter_link; 2460 $self->enter_link;
… …
2188 2480
2189 if ($gen == $self->{_goto_generation}) { 2481 if ($gen == $self->{_goto_generation}) {
2190 delete $self->{_goto_generation}; 2482 delete $self->{_goto_generation};
2191 $self->leave_link ($map, $x, $y); 2483 $self->leave_link ($map, $x, $y);
2192 } 2484 }
2485
2486 $done->() if $done;
2193 })->prio (1); 2487 })->prio (1);
2194} 2488}
2195 2489
2196=item $player_object->enter_exit ($exit_object) 2490=item $player_object->enter_exit ($exit_object)
2197 2491
… …
2266 my $hp = $exit->stats->hp; 2560 my $hp = $exit->stats->hp;
2267 my $sp = $exit->stats->sp; 2561 my $sp = $exit->stats->sp;
2268 2562
2269 $self->enter_link; 2563 $self->enter_link;
2270 2564
2565 # if exit is damned, update players death & WoR home-position
2566 $self->contr->savebed ($slaying, $hp, $sp)
2567 if $exit->flag (FLAG_DAMNED);
2568
2271 (async { 2569 (async {
2272 $self->deactivate_recursive; # just to be sure 2570 $self->deactivate_recursive; # just to be sure
2273 unless (eval { 2571 unless (eval {
2274 $self->goto ($slaying, $hp, $sp); 2572 $self->goto ($slaying, $hp, $sp);
2275 2573
… …
2302 2600
2303 utf8::encode $text; 2601 utf8::encode $text;
2304 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text); 2602 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
2305} 2603}
2306 2604
2605=item $client->send_msg ($channel, $msg, $color, [extra...])
2606
2607Send a drawinfo or msg packet to the client, formatting the msg for the
2608client if neccessary. C<$type> should be a string identifying the type of
2609the message, with C<log> being the default. If C<$color> is negative, suppress
2610the message unless the client supports the msg packet.
2611
2612=cut
2613
2614our %CHANNEL = (
2615 "c/identify" => {
2616 id => "identify",
2617 title => "Identify",
2618 reply => undef,
2619 tooltip => "Items recently identified",
2620 },
2621 "c/examine" => {
2622 id => "examine",
2623 title => "Examine",
2624 reply => undef,
2625 tooltip => "Signs and other items you examined",
2626 },
2627);
2628
2629sub cf::client::send_msg {
2630 my ($self, $channel, $msg, $color, @extra) = @_;
2631
2632 $msg = $self->pl->expand_cfpod ($msg);
2633
2634 $color &= cf::NDI_CLIENT_MASK; # just in case...
2635
2636 # check predefined channels, for the benefit of C
2637 $channel = $CHANNEL{$channel} if $CHANNEL{$channel};
2638
2639 if (ref $channel) {
2640 # send meta info to client, if not yet sent
2641 unless (exists $self->{channel}{$channel->{id}}) {
2642 $self->{channel}{$channel->{id}} = $channel;
2643 $self->ext_msg (channel_info => $channel)
2644 if $self->can_msg;
2645 }
2646
2647 $channel = $channel->{id};
2648 }
2649
2650 return unless @extra || length $msg;
2651
2652 if ($self->can_msg) {
2653 # default colour, mask it out
2654 $color &= ~(cf::NDI_COLOR_MASK | cf::NDI_DEF)
2655 if $color & cf::NDI_DEF;
2656
2657 $self->send_packet ("msg " . $self->{json_coder}->encode (
2658 [$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2659 } else {
2660 if ($color >= 0) {
2661 # replace some tags by gcfclient-compatible ones
2662 for ($msg) {
2663 1 while
2664 s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2665 || s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2666 || s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2667 || s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2668 || s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2669 }
2670
2671 $color &= cf::NDI_COLOR_MASK;
2672
2673 utf8::encode $msg;
2674
2675 if (0 && $msg =~ /\[/) {
2676 # COMMAND/INFO
2677 $self->send_packet ("drawextinfo $color 10 8 $msg")
2678 } else {
2679 $msg =~ s/\[\/?(?:b|i|u|fixed|color)[^\]]*\]//g;
2680 $self->send_packet ("drawinfo $color $msg")
2681 }
2682 }
2683 }
2684}
2685
2307=item $client->ext_event ($type, %msg) 2686=item $client->ext_msg ($type, @msg)
2308 2687
2309Sends an exti event to the client. 2688Sends an ext event to the client.
2310 2689
2311=cut 2690=cut
2312 2691
2313sub cf::client::ext_event($$%) { 2692sub cf::client::ext_msg($$@) {
2314 my ($self, $type, %msg) = @_; 2693 my ($self, $type, @msg) = @_;
2315 2694
2695 if ($self->extcmd == 2) {
2696 $self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
2697 } elsif ($self->extcmd == 1) { # TODO: remove
2316 $msg{msgtype} = "event_$type"; 2698 push @msg, msgtype => "event_$type";
2317 $self->send_packet ("ext " . cf::to_json \%msg); 2699 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2700 }
2701}
2702
2703=item $client->ext_reply ($msgid, @msg)
2704
2705Sends an ext reply to the client.
2706
2707=cut
2708
2709sub cf::client::ext_reply($$@) {
2710 my ($self, $id, @msg) = @_;
2711
2712 if ($self->extcmd == 2) {
2713 $self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
2714 } elsif ($self->extcmd == 1) {
2715 #TODO: version 1, remove
2716 unshift @msg, msgtype => "reply", msgid => $id;
2717 $self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
2718 }
2318} 2719}
2319 2720
2320=item $success = $client->query ($flags, "text", \&cb) 2721=item $success = $client->query ($flags, "text", \&cb)
2321 2722
2322Queues a query to the client, calling the given callback with 2723Queues a query to the client, calling the given callback with
2323the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2724the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
2324C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>. 2725C<cf::CS_QUERY_SINGLECHAR> or C<cf::CS_QUERY_HIDEINPUT> or C<0>.
2325 2726
2326Queries can fail, so check the return code. Or don't, as queries will become 2727Queries can fail, so check the return code. Or don't, as queries will
2327reliable at some point in the future. 2728become reliable at some point in the future.
2328 2729
2329=cut 2730=cut
2330 2731
2331sub cf::client::query { 2732sub cf::client::query {
2332 my ($self, $flags, $text, $cb) = @_; 2733 my ($self, $flags, $text, $cb) = @_;
… …
2340 utf8::encode $text; 2741 utf8::encode $text;
2341 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb]; 2742 push @{ $self->{query_queue} }, [(sprintf "query %d %s", $flags, $text), $cb];
2342 2743
2343 $self->send_packet ($self->{query_queue}[0][0]) 2744 $self->send_packet ($self->{query_queue}[0][0])
2344 if @{ $self->{query_queue} } == 1; 2745 if @{ $self->{query_queue} } == 1;
2746
2747 1
2345} 2748}
2346 2749
2347cf::client->attach ( 2750cf::client->attach (
2751 on_connect => sub {
2752 my ($ns) = @_;
2753
2754 $ns->{json_coder} = JSON::XS->new->utf8->max_size (1e6)->convert_blessed;
2755 },
2348 on_reply => sub { 2756 on_reply => sub {
2349 my ($ns, $msg) = @_; 2757 my ($ns, $msg) = @_;
2350 2758
2351 # this weird shuffling is so that direct followup queries 2759 # this weird shuffling is so that direct followup queries
2352 # get handled first 2760 # get handled first
… …
2364 } else { 2772 } else {
2365 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM; 2773 $ns->state (ST_PLAYING) if $ns->state == ST_CUSTOM;
2366 } 2774 }
2367 } 2775 }
2368 }, 2776 },
2777 on_exticmd => sub {
2778 my ($ns, $buf) = @_;
2779
2780 my $msg = eval { $ns->{json_coder}->decode ($buf) };
2781
2782 if (ref $msg) {
2783 my ($type, $reply, @payload) =
2784 "ARRAY" eq ref $msg
2785 ? @$msg
2786 : ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
2787
2788 my @reply;
2789
2790 if (my $cb = $EXTICMD{$type}) {
2791 @reply = $cb->($ns, @payload);
2792 }
2793
2794 $ns->ext_reply ($reply, @reply)
2795 if $reply;
2796
2797 } else {
2798 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2799 }
2800
2801 cf::override;
2802 },
2369); 2803);
2370 2804
2371=item $client->async (\&cb) 2805=item $client->async (\&cb)
2372 2806
2373Create a new coroutine, running the specified callback. The coroutine will 2807Create a new coroutine, running the specified callback. The coroutine will
… …
2414our $safe = new Safe "safe"; 2848our $safe = new Safe "safe";
2415our $safe_hole = new Safe::Hole; 2849our $safe_hole = new Safe::Hole;
2416 2850
2417$SIG{FPE} = 'IGNORE'; 2851$SIG{FPE} = 'IGNORE';
2418 2852
2419$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time)); 2853$safe->permit_only (Opcode::opset qw(
2854 :base_core :base_mem :base_orig :base_math
2855 grepstart grepwhile mapstart mapwhile
2856 sort time
2857));
2420 2858
2421# here we export the classes and methods available to script code 2859# here we export the classes and methods available to script code
2422 2860
2423=pod 2861=pod
2424 2862
2425The following functions and methods are available within a safe environment: 2863The following functions and methods are available within a safe environment:
2426 2864
2427 cf::object contr pay_amount pay_player map 2865 cf::object
2866 contr pay_amount pay_player map x y force_find force_add
2867 insert remove name archname title slaying race decrease_ob_nr
2868
2428 cf::object::player player 2869 cf::object::player
2429 cf::player peaceful 2870 player
2430 cf::map trigger 2871
2872 cf::player
2873 peaceful
2874
2875 cf::map
2876 trigger
2431 2877
2432=cut 2878=cut
2433 2879
2434for ( 2880for (
2435 ["cf::object" => qw(contr pay_amount pay_player map)], 2881 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2882 insert remove inv name archname title slaying race
2883 decrease_ob_nr)],
2436 ["cf::object::player" => qw(player)], 2884 ["cf::object::player" => qw(player)],
2437 ["cf::player" => qw(peaceful)], 2885 ["cf::player" => qw(peaceful)],
2438 ["cf::map" => qw(trigger)], 2886 ["cf::map" => qw(trigger)],
2439) { 2887) {
2440 no strict 'refs'; 2888 no strict 'refs';
… …
2516# the server's init and main functions 2964# the server's init and main functions
2517 2965
2518sub load_facedata($) { 2966sub load_facedata($) {
2519 my ($path) = @_; 2967 my ($path) = @_;
2520 2968
2969 # HACK to clear player env face cache, we need some signal framework
2970 # for this (global event?)
2971 %ext::player_env::MUSIC_FACE_CACHE = ();
2972
2973 my $enc = JSON::XS->new->utf8->canonical->relaxed;
2974
2521 warn "loading facedata from $path\n"; 2975 warn "loading facedata from $path\n";
2522 2976
2523 my $facedata; 2977 my $facedata;
2524 0 < aio_load $path, $facedata 2978 0 < aio_load $path, $facedata
2525 or die "$path: $!"; 2979 or die "$path: $!";
… …
2527 $facedata = Coro::Storable::thaw $facedata; 2981 $facedata = Coro::Storable::thaw $facedata;
2528 2982
2529 $facedata->{version} == 2 2983 $facedata->{version} == 2
2530 or cf::cleanup "$path: version mismatch, cannot proceed."; 2984 or cf::cleanup "$path: version mismatch, cannot proceed.";
2531 2985
2986 # patch in the exptable
2987 $facedata->{resource}{"res/exp_table"} = {
2988 type => FT_RSRC,
2989 data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
2990 };
2991 cf::cede_to_tick;
2992
2532 { 2993 {
2533 my $faces = $facedata->{faceinfo}; 2994 my $faces = $facedata->{faceinfo};
2534 2995
2535 while (my ($face, $info) = each %$faces) { 2996 while (my ($face, $info) = each %$faces) {
2536 my $idx = (cf::face::find $face) || cf::face::alloc $face; 2997 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2537 cf::face::set $idx, $info->{visibility}, $info->{magicmap}; 2998 cf::face::set_visibility $idx, $info->{visibility};
2999 cf::face::set_magicmap $idx, $info->{magicmap};
2538 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32}; 3000 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2539 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64}; 3001 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2540 Coro::cede; 3002
3003 cf::cede_to_tick;
2541 } 3004 }
2542 3005
2543 while (my ($face, $info) = each %$faces) { 3006 while (my ($face, $info) = each %$faces) {
2544 next unless $info->{smooth}; 3007 next unless $info->{smooth};
2545 my $idx = cf::face::find $face 3008 my $idx = cf::face::find $face
2546 or next; 3009 or next;
2547 if (my $smooth = cf::face::find $info->{smooth}) { 3010 if (my $smooth = cf::face::find $info->{smooth}) {
3011 cf::face::set_smooth $idx, $smooth;
2548 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel}; 3012 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2549 } else { 3013 } else {
2550 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3014 warn "smooth face '$info->{smooth}' not found for face '$face'";
2551 } 3015 }
2552 Coro::cede; 3016
3017 cf::cede_to_tick;
2553 } 3018 }
2554 } 3019 }
2555 3020
2556 { 3021 {
2557 my $anims = $facedata->{animinfo}; 3022 my $anims = $facedata->{animinfo};
2558 3023
2559 while (my ($anim, $info) = each %$anims) { 3024 while (my ($anim, $info) = each %$anims) {
2560 cf::anim::set $anim, $info->{frames}, $info->{facings}; 3025 cf::anim::set $anim, $info->{frames}, $info->{facings};
2561 Coro::cede; 3026 cf::cede_to_tick;
2562 } 3027 }
2563 3028
2564 cf::anim::invalidate_all; # d'oh 3029 cf::anim::invalidate_all; # d'oh
2565 } 3030 }
2566 3031
3032 {
3033 # TODO: for gcfclient pleasure, we should give resources
3034 # that gcfclient doesn't grok a >10000 face index.
3035 my $res = $facedata->{resource};
3036
3037 my $soundconf = delete $res->{"res/sound.conf"};
3038
3039 while (my ($name, $info) = each %$res) {
3040 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3041 my $data;
3042
3043 if ($info->{type} & 1) {
3044 # prepend meta info
3045
3046 my $meta = $enc->encode ({
3047 name => $name,
3048 %{ $info->{meta} || {} },
3049 });
3050
3051 $data = pack "(w/a*)*", $meta, $info->{data};
3052 } else {
3053 $data = $info->{data};
3054 }
3055
3056 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3057 cf::face::set_type $idx, $info->{type};
3058
3059 cf::cede_to_tick;
3060 }
3061
3062 if ($soundconf) {
3063 $soundconf = $enc->decode (delete $soundconf->{data});
3064
3065 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3066 my $sound = $soundconf->{compat}[$_]
3067 or next;
3068
3069 my $face = cf::face::find "sound/$sound->[1]";
3070 cf::sound::set $sound->[0] => $face;
3071 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3072 }
3073
3074 while (my ($k, $v) = each %{$soundconf->{event}}) {
3075 my $face = cf::face::find "sound/$v";
3076 cf::sound::set $k => $face;
3077 }
3078 }
3079 }
3080
2567 1 3081 1
2568} 3082}
2569 3083
3084register_exticmd fx_want => sub {
3085 my ($ns, $want) = @_;
3086
3087 while (my ($k, $v) = each %$want) {
3088 $ns->fx_want ($k, $v);
3089 }
3090};
3091
2570sub reload_regions { 3092sub reload_regions {
3093 # HACK to clear player env face cache, we need some signal framework
3094 # for this (global event?)
3095 %ext::player_env::MUSIC_FACE_CACHE = ();
3096
2571 load_resource_file "$MAPDIR/regions" 3097 load_resource_file "$MAPDIR/regions"
2572 or die "unable to load regions file\n"; 3098 or die "unable to load regions file\n";
3099
3100 for (cf::region::list) {
3101 $_->{match} = qr/$_->{match}/
3102 if exists $_->{match};
3103 }
2573} 3104}
2574 3105
2575sub reload_facedata { 3106sub reload_facedata {
2576 load_facedata "$DATADIR/facedata" 3107 load_facedata "$DATADIR/facedata"
2577 or die "unable to load facedata\n"; 3108 or die "unable to load facedata\n";
2578} 3109}
2579 3110
2580sub reload_archetypes { 3111sub reload_archetypes {
3112 load_resource_file "$DATADIR/archetypes"
3113 or die "unable to load archetypes\n";
3114 #d# NEED to laod twice to resolve forward references
3115 # this really needs to be done in an extra post-pass
3116 # (which needs to be synchronous, so solve it differently)
2581 load_resource_file "$DATADIR/archetypes" 3117 load_resource_file "$DATADIR/archetypes"
2582 or die "unable to load archetypes\n"; 3118 or die "unable to load archetypes\n";
2583} 3119}
2584 3120
2585sub reload_treasures { 3121sub reload_treasures {
… …
2601 3137
2602sub init { 3138sub init {
2603 reload_resources; 3139 reload_resources;
2604} 3140}
2605 3141
2606sub cfg_load { 3142sub reload_config {
2607 open my $fh, "<:utf8", "$CONFDIR/config" 3143 open my $fh, "<:utf8", "$CONFDIR/config"
2608 or return; 3144 or return;
2609 3145
2610 local $/; 3146 local $/;
2611 *CFG = YAML::Syck::Load <$fh>; 3147 *CFG = YAML::Syck::Load <$fh>;
… …
2631 (async { 3167 (async {
2632 Event::one_event; 3168 Event::one_event;
2633 })->prio (Coro::PRIO_MAX); 3169 })->prio (Coro::PRIO_MAX);
2634 }; 3170 };
2635 3171
2636 cfg_load; 3172 reload_config;
2637 db_init; 3173 db_init;
2638 load_extensions; 3174 load_extensions;
2639 3175
2640 $TICK_WATCHER->start; 3176 $TICK_WATCHER->start;
2641 Event::loop; 3177 Event::loop;
… …
2779 %EXT_CORO = (); 3315 %EXT_CORO = ();
2780 3316
2781 warn "removing commands"; 3317 warn "removing commands";
2782 %COMMAND = (); 3318 %COMMAND = ();
2783 3319
2784 warn "removing ext commands"; 3320 warn "removing ext/exti commands";
2785 %EXTCMD = (); 3321 %EXTCMD = ();
3322 %EXTICMD = ();
2786 3323
2787 warn "unloading/nuking all extensions"; 3324 warn "unloading/nuking all extensions";
2788 for my $pkg (@EXTS) { 3325 for my $pkg (@EXTS) {
2789 warn "... unloading $pkg"; 3326 warn "... unloading $pkg";
2790 3327
… …
2833 warn "reloading cf.pm"; 3370 warn "reloading cf.pm";
2834 require cf; 3371 require cf;
2835 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 3372 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2836 3373
2837 warn "loading config and database again"; 3374 warn "loading config and database again";
2838 cf::cfg_load; 3375 cf::reload_config;
2839 3376
2840 warn "loading extensions"; 3377 warn "loading extensions";
2841 cf::load_extensions; 3378 cf::load_extensions;
2842 3379
2843 warn "reattaching attachments to objects/players"; 3380 warn "reattaching attachments to objects/players";
… …
2936 or die; 3473 or die;
2937 3474
2938 $map->width (50); 3475 $map->width (50);
2939 $map->height (50); 3476 $map->height (50);
2940 $map->alloc; 3477 $map->alloc;
2941 $map->_load_objects ("/tmp/x.map", 1); 3478 $map->_load_objects ("/tmp/x.map", 1); #TODO: does not work
2942 my $t = Event::time - $t; 3479 my $t = Event::time - $t;
2943 3480
2944 #next unless $t < 0.0013;#d# 3481 #next unless $t < 0.0013;#d#
2945 if ($t < $min) { 3482 if ($t < $min) {
2946 $min = $t; 3483 $min = $t;
… …
2989 3526
2990 }, 3527 },
2991); 3528);
2992 3529
2993{ 3530{
3531 BDB::min_parallel 8;
2994 BDB::max_poll_time $TICK * 0.1; 3532 BDB::max_poll_time $TICK * 0.1;
2995 $BDB_POLL_WATCHER = Event->io ( 3533 $BDB_POLL_WATCHER = Event->io (
2996 reentrant => 0, 3534 reentrant => 0,
2997 fd => BDB::poll_fileno, 3535 fd => BDB::poll_fileno,
2998 poll => 'r', 3536 poll => 'r',
2999 prio => 0, 3537 prio => 0,
3000 data => WF_AUTOCANCEL, 3538 data => WF_AUTOCANCEL,
3001 cb => \&BDB::poll_cb, 3539 cb => \&BDB::poll_cb,
3002 ); 3540 );
3003 BDB::min_parallel 8;
3004 3541
3005 BDB::set_sync_prepare { 3542 BDB::set_sync_prepare {
3006 my $status; 3543 my $status;
3007 my $current = $Coro::current; 3544 my $current = $Coro::current;
3008 ( 3545 (
… …
3029 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3566 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3030 0666; 3567 0666;
3031 3568
3032 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3569 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3033 3570
3034 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 3571 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3572 | BDB::LOG_AUTOREMOVE, 1);
3035 $DB_ENV->set_lk_detect; 3573 $DB_ENV->set_lk_detect;
3036 }; 3574 };
3037 3575
3038 cf::cleanup "db_env_open(db): $@" if $@; 3576 cf::cleanup "db_env_open(db): $@" if $@;
3039 }; 3577 };
3040 } 3578 }
3579
3580 $BDB_CHECKPOINT_WATCHER = Event->timer (
3581 after => 11,
3582 interval => 60,
3583 hard => 1,
3584 prio => 0,
3585 data => WF_AUTOCANCEL,
3586 cb => sub {
3587 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3588 },
3589 );
3590 $BDB_TRICKLE_WATCHER = Event->timer (
3591 after => 5,
3592 interval => 10,
3593 hard => 1,
3594 prio => 0,
3595 data => WF_AUTOCANCEL,
3596 cb => sub {
3597 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3598 },
3599 );
3041} 3600}
3042 3601
3043{ 3602{
3044 IO::AIO::min_parallel 8; 3603 IO::AIO::min_parallel 8;
3045 3604

Diff Legend

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