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.355 by root, Sun Sep 2 12:45:44 2007 UTC vs.
Revision 1.408 by root, Mon Jan 14 10:12:12 2008 UTC

… …
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket; 8use Socket;
9use Storable; 9use EV 1.86;
10use Event;
11use Opcode; 10use Opcode;
12use Safe; 11use Safe;
13use Safe::Hole; 12use Safe::Hole;
13use Storable ();
14 14
15use Coro 3.64 (); 15use Coro 4.32 ();
16use Coro::State; 16use Coro::State;
17use Coro::Handle; 17use Coro::Handle;
18use Coro::Event; 18use Coro::EV;
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::BDB;
23use Coro::Storable; 24use Coro::Storable;
24use Coro::Util (); 25use Coro::Util ();
25 26
26use JSON::XS (); 27use JSON::XS 2.01 ();
27use BDB (); 28use BDB ();
28use Data::Dumper; 29use Data::Dumper;
29use Digest::MD5; 30use Digest::MD5;
30use Fcntl; 31use Fcntl;
31use YAML::Syck (); 32use YAML ();
32use IO::AIO 2.32 (); 33use IO::AIO 2.51 ();
33use Time::HiRes; 34use Time::HiRes;
34use Compress::LZF; 35use Compress::LZF;
35use Digest::MD5 (); 36use Digest::MD5 ();
36 37
37# configure various modules to our taste 38# configure various modules to our taste
38# 39#
39$Storable::canonical = 1; # reduce rsync transfers 40$Storable::canonical = 1; # reduce rsync transfers
40Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator 41Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
41Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 42Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
42
43$Event::Eval = 1; # no idea why this is required, but it is
44
45# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
46$YAML::Syck::ImplicitUnicode = 1;
47 43
48$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 44$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
49 45
50sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 46sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
51 47
… …
70our $TMPDIR = "$LOCALDIR/" . tmpdir; 66our $TMPDIR = "$LOCALDIR/" . tmpdir;
71our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
72our $PLAYERDIR = "$LOCALDIR/" . playerdir; 68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
73our $RANDOMDIR = "$LOCALDIR/random"; 69our $RANDOMDIR = "$LOCALDIR/random";
74our $BDBDIR = "$LOCALDIR/db"; 70our $BDBDIR = "$LOCALDIR/db";
71our %RESOURCE;
75 72
76our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 73our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
77our $TICK_WATCHER; 74our $TICK_WATCHER;
78our $AIO_POLL_WATCHER; 75our $AIO_POLL_WATCHER;
79our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 76our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
80our $NEXT_TICK; 77our $NEXT_TICK;
81our $NOW;
82our $USE_FSYNC = 1; # use fsync to write maps - default off 78our $USE_FSYNC = 1; # use fsync to write maps - default off
83 79
84our $BDB_POLL_WATCHER; 80our $BDB_POLL_WATCHER;
81our $BDB_DEADLOCK_WATCHER;
82our $BDB_CHECKPOINT_WATCHER;
83our $BDB_TRICKLE_WATCHER;
85our $DB_ENV; 84our $DB_ENV;
86 85
87our %CFG; 86our %CFG;
88 87
89our $UPTIME; $UPTIME ||= time; 88our $UPTIME; $UPTIME ||= time;
90our $RUNTIME; 89our $RUNTIME;
90our $NOW;
91 91
92our %PLAYER; # all users 92our (%PLAYER, %PLAYER_LOADING); # all users
93our %MAP; # all maps 93our (%MAP, %MAP_LOADING ); # all maps
94our $LINK_MAP; # the special {link} map, which is always available 94our $LINK_MAP; # the special {link} map, which is always available
95 95
96# used to convert map paths into valid unix filenames by replacing / by ∕ 96# used to convert map paths into valid unix filenames by replacing / by ∕
97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 97our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
98 98
… …
159 159
160The raw value load value from the last tick. 160The raw value load value from the last tick.
161 161
162=item %cf::CFG 162=item %cf::CFG
163 163
164Configuration for the server, loaded from C</etc/crossfire/config>, or 164Configuration for the server, loaded from C</etc/deliantra-server/config>, or
165from wherever your confdir points to. 165from wherever your confdir points to.
166 166
167=item cf::wait_for_tick, cf::wait_for_tick_begin 167=item cf::wait_for_tick, cf::wait_for_tick_begin
168 168
169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 169These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
… …
187 $msg .= "\n" 187 $msg .= "\n"
188 unless $msg =~ /\n$/; 188 unless $msg =~ /\n$/;
189 189
190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 190 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
191 191
192 utf8::encode $msg;
193 LOG llevError, $msg; 192 LOG llevError, $msg;
194 }; 193 };
195} 194}
195
196$Coro::State::DIEHOOK = sub {
197 warn Carp::longmess $_[0];
198 Coro::terminate;
199};
196 200
197@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 201@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
198@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 202@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
199@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable'; 203@safe::cf::player::ISA = @cf::player::ISA = 'cf::attachable';
200@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable'; 204@safe::cf::client::ISA = @cf::client::ISA = 'cf::attachable';
… …
213)) { 217)) {
214 no strict 'refs'; 218 no strict 'refs';
215 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg; 219 @{"safe::$pkg\::wrap::ISA"} = @{"$pkg\::wrap::ISA"} = $pkg;
216} 220}
217 221
218$Event::DIED = sub { 222$EV::DIED = sub {
219 warn "error in event callback: @_"; 223 warn "error in event callback: @_";
220}; 224};
221 225
222############################################################################# 226#############################################################################
223 227
… …
246 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 250 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
247 $d 251 $d
248 } || "[unable to dump $_[0]: '$@']"; 252 } || "[unable to dump $_[0]: '$@']";
249} 253}
250 254
251=item $ref = cf::from_json $json 255=item $ref = cf::decode_json $json
252 256
253Converts a JSON string into the corresponding perl data structure. 257Converts a JSON string into the corresponding perl data structure.
254 258
255=item $json = cf::to_json $ref 259=item $json = cf::encode_json $ref
256 260
257Converts a perl data structure into its JSON representation. 261Converts a perl data structure into its JSON representation.
258 262
259=cut 263=cut
260 264
261our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 265our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
262 266
263sub to_json ($) { $json_coder->encode ($_[0]) } 267sub encode_json($) { $json_coder->encode ($_[0]) }
264sub from_json ($) { $json_coder->decode ($_[0]) } 268sub decode_json($) { $json_coder->decode ($_[0]) }
265 269
266=item cf::lock_wait $string 270=item cf::lock_wait $string
267 271
268Wait until the given lock is available. See cf::lock_acquire. 272Wait until the given lock is available. See cf::lock_acquire.
269 273
… …
285Return true if the lock is currently active, i.e. somebody has locked it. 289Return true if the lock is currently active, i.e. somebody has locked it.
286 290
287=cut 291=cut
288 292
289our %LOCK; 293our %LOCK;
294our %LOCKER;#d#
290 295
291sub lock_wait($) { 296sub lock_wait($) {
292 my ($key) = @_; 297 my ($key) = @_;
298
299 if ($LOCKER{$key} == $Coro::current) {#d#
300 Carp::cluck "lock_wait($key) for already-acquired lock";#d#
301 return;#d#
302 }#d#
293 303
294 # wait for lock, if any 304 # wait for lock, if any
295 while ($LOCK{$key}) { 305 while ($LOCK{$key}) {
296 push @{ $LOCK{$key} }, $Coro::current; 306 push @{ $LOCK{$key} }, $Coro::current;
297 Coro::schedule; 307 Coro::schedule;
… …
303 313
304 # wait, to be sure we are not locked 314 # wait, to be sure we are not locked
305 lock_wait $key; 315 lock_wait $key;
306 316
307 $LOCK{$key} = []; 317 $LOCK{$key} = [];
318 $LOCKER{$key} = $Coro::current;#d#
308 319
309 Coro::guard { 320 Coro::guard {
321 delete $LOCKER{$key};#d#
310 # wake up all waiters, to be on the safe side 322 # wake up all waiters, to be on the safe side
311 $_->ready for @{ delete $LOCK{$key} }; 323 $_->ready for @{ delete $LOCK{$key} };
312 } 324 }
313} 325}
314 326
… …
326 }; 338 };
327 $TICK_WATCHER->stop; 339 $TICK_WATCHER->stop;
328 $guard 340 $guard
329} 341}
330 342
343=item cf::periodic $interval, $cb
344
345Like EV::periodic, but randomly selects a starting point so that the actions
346get spread over timer.
347
348=cut
349
350sub periodic($$) {
351 my ($interval, $cb) = @_;
352
353 my $start = rand List::Util::min 180, $interval;
354
355 EV::periodic $start, $interval, 0, $cb
356}
357
331=item cf::get_slot $time[, $priority[, $name]] 358=item cf::get_slot $time[, $priority[, $name]]
332 359
333Allocate $time seconds of blocking CPU time at priority C<$priority>: 360Allocate $time seconds of blocking CPU time at priority C<$priority>:
334This call blocks and returns only when you have at least C<$time> seconds 361This call blocks and returns only when you have at least C<$time> seconds
335of cpu time till the next tick. The slot is only valid till the next cede. 362of cpu time till the next tick. The slot is only valid till the next cede.
… …
344our @SLOT_QUEUE; 371our @SLOT_QUEUE;
345our $SLOT_QUEUE; 372our $SLOT_QUEUE;
346 373
347$SLOT_QUEUE->cancel if $SLOT_QUEUE; 374$SLOT_QUEUE->cancel if $SLOT_QUEUE;
348$SLOT_QUEUE = Coro::async { 375$SLOT_QUEUE = Coro::async {
376 $Coro::current->desc ("timeslot manager");
377
349 my $signal = new Coro::Signal; 378 my $signal = new Coro::Signal;
350 379
351 while () { 380 while () {
352 next_job: 381 next_job:
353 my $avail = cf::till_tick; 382 my $avail = cf::till_tick;
… …
361 } 390 }
362 } 391 }
363 } 392 }
364 393
365 if (@SLOT_QUEUE) { 394 if (@SLOT_QUEUE) {
366 # we do not use wait_For_tick() as it returns immediately when tick is inactive 395 # we do not use wait_for_tick() as it returns immediately when tick is inactive
367 push @cf::WAIT_FOR_TICK, $signal; 396 push @cf::WAIT_FOR_TICK, $signal;
368 $signal->wait; 397 $signal->wait;
369 } else { 398 } else {
370 Coro::schedule; 399 Coro::schedule;
371 } 400 }
… …
394 423
395BEGIN { *async = \&Coro::async_pool } 424BEGIN { *async = \&Coro::async_pool }
396 425
397=item cf::sync_job { BLOCK } 426=item cf::sync_job { BLOCK }
398 427
399The design of Crossfire TRT requires that the main coroutine ($Coro::main) 428The design of Deliantra requires that the main coroutine ($Coro::main)
400is always able to handle events or runnable, as Crossfire TRT is only 429is always able to handle events or runnable, as Deliantra is only
401partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not 430partly reentrant. Thus "blocking" it by e.g. waiting for I/O is not
402acceptable. 431acceptable.
403 432
404If it must be done, put the blocking parts into C<sync_job>. This will run 433If it must be done, put the blocking parts into C<sync_job>. This will run
405the given BLOCK in another coroutine while waiting for the result. The 434the given BLOCK in another coroutine while waiting for the result. The
… …
410 439
411sub sync_job(&) { 440sub sync_job(&) {
412 my ($job) = @_; 441 my ($job) = @_;
413 442
414 if ($Coro::current == $Coro::main) { 443 if ($Coro::current == $Coro::main) {
415 my $time = Event::time; 444 my $time = EV::time;
416 445
417 # this is the main coro, too bad, we have to block 446 # this is the main coro, too bad, we have to block
418 # till the operation succeeds, freezing the server :/ 447 # till the operation succeeds, freezing the server :/
419 448
449 LOG llevError, Carp::longmess "sync job";#d#
450
420 # TODO: use suspend/resume instead 451 # TODO: use suspend/resume instead
421 # (but this is cancel-safe) 452 # (but this is cancel-safe)
422 my $freeze_guard = freeze_mainloop; 453 my $freeze_guard = freeze_mainloop;
423 454
424 my $busy = 1; 455 my $busy = 1;
425 my @res; 456 my @res;
426 457
427 (async { 458 (async {
459 $Coro::current->desc ("sync job coro");
428 @res = eval { $job->() }; 460 @res = eval { $job->() };
429 warn $@ if $@; 461 warn $@ if $@;
430 undef $busy; 462 undef $busy;
431 })->prio (Coro::PRIO_MAX); 463 })->prio (Coro::PRIO_MAX);
432 464
433 while ($busy) { 465 while ($busy) {
434 Coro::cede or Event::one_event; 466 if (Coro::nready) {
467 Coro::cede_notself;
468 } else {
469 EV::loop EV::LOOP_ONESHOT;
435 } 470 }
471 }
436 472
437 $time = Event::time - $time; 473 $time = EV::time - $time;
438 474
439 LOG llevError | logBacktrace, Carp::longmess "long sync job" 475 LOG llevError | logBacktrace, Carp::longmess "long sync job"
440 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active; 476 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
441 477
442 $tick_start += $time; # do not account sync jobs to server load 478 $tick_start += $time; # do not account sync jobs to server load
… …
472=item fork_call { }, $args 508=item fork_call { }, $args
473 509
474Executes the given code block with the given arguments in a seperate 510Executes the given code block with the given arguments in a seperate
475process, returning the results. Everything must be serialisable with 511process, returning the results. Everything must be serialisable with
476Coro::Storable. May, of course, block. Note that the executed sub may 512Coro::Storable. May, of course, block. Note that the executed sub may
477never block itself or use any form of Event handling. 513never block itself or use any form of event handling.
478 514
479=cut 515=cut
480 516
481sub fork_call(&@) { 517sub fork_call(&@) {
482 my ($cb, @args) = @_; 518 my ($cb, @args) = @_;
… …
500=item cf::db_put $family => $key => $value 536=item cf::db_put $family => $key => $value
501 537
502Stores the given C<$value> in the family. It can currently store binary 538Stores the given C<$value> in the family. It can currently store binary
503data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary). 539data only (use Compress::LZF::sfreeze_cr/sthaw to convert to/from binary).
504 540
541=item $db = cf::db_table "name"
542
543Create and/or open a new database table. The string must not be "db" and must be unique
544within each server.
545
505=cut 546=cut
547
548sub db_table($) {
549 my ($name) = @_;
550 my $db = BDB::db_create $DB_ENV;
551
552 eval {
553 $db->set_flags (BDB::CHKSUM);
554
555 utf8::encode $name;
556 BDB::db_open $db, undef, $name, undef, BDB::BTREE,
557 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
558 cf::cleanup "db_open(db): $!" if $!;
559 };
560 cf::cleanup "db_open(db): $@" if $@;
561
562 $db
563}
506 564
507our $DB; 565our $DB;
508 566
509sub db_init { 567sub db_init {
510 unless ($DB) {
511 $DB = BDB::db_create $DB_ENV;
512
513 cf::sync_job { 568 cf::sync_job {
514 eval { 569 $DB ||= db_table "db";
515 $DB->set_flags (BDB::CHKSUM);
516
517 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
518 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
519 cf::cleanup "db_open(db): $!" if $!;
520 };
521 cf::cleanup "db_open(db): $@" if $@;
522 };
523 } 570 };
524} 571}
525 572
526sub db_get($$) { 573sub db_get($$) {
527 my $key = "$_[0]/$_[1]"; 574 my $key = "$_[0]/$_[1]";
528 575
… …
632attach callbacks/event handlers (a collection of which is called an "attachment") 679attach callbacks/event handlers (a collection of which is called an "attachment")
633to it. All such attachable objects support the following methods. 680to it. All such attachable objects support the following methods.
634 681
635In the following description, CLASS can be any of C<global>, C<object> 682In the following description, CLASS can be any of C<global>, C<object>
636C<player>, C<client> or C<map> (i.e. the attachable objects in 683C<player>, C<client> or C<map> (i.e. the attachable objects in
637Crossfire TRT). 684Deliantra).
638 685
639=over 4 686=over 4
640 687
641=item $attachable->attach ($attachment, key => $value...) 688=item $attachable->attach ($attachment, key => $value...)
642 689
… …
924 } 971 }
925 972
926 0 973 0
927} 974}
928 975
929=item $bool = cf::global::invoke (EVENT_CLASS_XXX, ...) 976=item $bool = cf::global->invoke (EVENT_CLASS_XXX, ...)
930 977
931=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...) 978=item $bool = $attachable->invoke (EVENT_CLASS_XXX, ...)
932 979
933Generate an object-specific event with the given arguments. 980Generate an object-specific event with the given arguments.
934 981
… …
940 987
941=cut 988=cut
942 989
943############################################################################# 990#############################################################################
944# object support 991# object support
945#
946 992
993sub _object_equal($$);
994sub _object_equal($$) {
995 my ($a, $b) = @_;
996
997 return 0 unless (ref $a) eq (ref $b);
998
999 if ("HASH" eq ref $a) {
1000 my @ka = keys %$a;
1001 my @kb = keys %$b;
1002
1003 return 0 if @ka != @kb;
1004
1005 for (0 .. $#ka) {
1006 return 0 unless $ka[$_] eq $kb[$_];
1007 return 0 unless _object_equal $a->{$ka[$_]}, $b->{$kb[$_]};
1008 }
1009
1010 } elsif ("ARRAY" eq ref $a) {
1011
1012 return 0 if @$a != @$b;
1013
1014 for (0 .. $#$a) {
1015 return 0 unless _object_equal $a->[$_], $b->[$_];
1016 }
1017
1018 } elsif ($a ne $b) {
1019 return 0;
1020 }
1021
1022 1
1023}
1024
1025our $SLOW_MERGES;#d#
947sub _can_merge { 1026sub _can_merge {
948 my ($ob1, $ob2) = @_; 1027 my ($ob1, $ob2) = @_;
949 1028
950 local $Storable::canonical = 1; 1029 ++$SLOW_MERGES;#d#
951 my $fob1 = Storable::freeze $ob1;
952 my $fob2 = Storable::freeze $ob2;
953 1030
954 $fob1 eq $fob2 1031 # we do the slow way here
1032 return _object_equal $ob1, $ob2
955} 1033}
956 1034
957sub reattach { 1035sub reattach {
958 # basically do the same as instantiate, without calling instantiate 1036 # basically do the same as instantiate, without calling instantiate
959 my ($obj) = @_; 1037 my ($obj) = @_;
… …
981cf::attachable->attach ( 1059cf::attachable->attach (
982 prio => -1000000, 1060 prio => -1000000,
983 on_instantiate => sub { 1061 on_instantiate => sub {
984 my ($obj, $data) = @_; 1062 my ($obj, $data) = @_;
985 1063
986 $data = from_json $data; 1064 $data = decode_json $data;
987 1065
988 for (@$data) { 1066 for (@$data) {
989 my ($name, $args) = @$_; 1067 my ($name, $args) = @$_;
990 1068
991 $obj->attach ($name, %{$args || {} }); 1069 $obj->attach ($name, %{$args || {} });
… …
1007sub object_freezer_save { 1085sub object_freezer_save {
1008 my ($filename, $rdata, $objs) = @_; 1086 my ($filename, $rdata, $objs) = @_;
1009 1087
1010 sync_job { 1088 sync_job {
1011 if (length $$rdata) { 1089 if (length $$rdata) {
1090 utf8::decode (my $decname = $filename);
1012 warn sprintf "saving %s (%d,%d)\n", 1091 warn sprintf "saving %s (%d,%d)\n",
1013 $filename, length $$rdata, scalar @$objs; 1092 $decname, length $$rdata, scalar @$objs;
1014 1093
1015 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1094 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1016 chmod SAVE_MODE, $fh; 1095 chmod SAVE_MODE, $fh;
1017 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1096 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1018 aio_fsync $fh if $cf::USE_FSYNC; 1097 aio_fsync $fh if $cf::USE_FSYNC;
1019 close $fh; 1098 close $fh;
1020 1099
1021 if (@$objs) { 1100 if (@$objs) {
1022 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 1101 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
1023 chmod SAVE_MODE, $fh; 1102 chmod SAVE_MODE, $fh;
1024 my $data = Storable::nfreeze { version => 1, objs => $objs }; 1103 my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1025 aio_write $fh, 0, (length $data), $data, 0; 1104 aio_write $fh, 0, (length $data), $data, 0;
1026 aio_fsync $fh if $cf::USE_FSYNC; 1105 aio_fsync $fh if $cf::USE_FSYNC;
1027 close $fh; 1106 close $fh;
1028 aio_rename "$filename.pst~", "$filename.pst"; 1107 aio_rename "$filename.pst~", "$filename.pst";
1029 } 1108 }
… …
1037 } 1116 }
1038 } else { 1117 } else {
1039 aio_unlink $filename; 1118 aio_unlink $filename;
1040 aio_unlink "$filename.pst"; 1119 aio_unlink "$filename.pst";
1041 } 1120 }
1042 } 1121 };
1043} 1122}
1044 1123
1045sub object_freezer_as_string { 1124sub object_freezer_as_string {
1046 my ($rdata, $objs) = @_; 1125 my ($rdata, $objs) = @_;
1047 1126
… …
1059 or return; 1138 or return;
1060 1139
1061 unless (aio_stat "$filename.pst") { 1140 unless (aio_stat "$filename.pst") {
1062 (aio_load "$filename.pst", $av) >= 0 1141 (aio_load "$filename.pst", $av) >= 0
1063 or return; 1142 or return;
1143
1064 $av = eval { (Storable::thaw $av)->{objs} }; 1144 my $st = eval { Coro::Storable::thaw $av };
1145 $av = $st->{objs};
1065 } 1146 }
1066 1147
1148 utf8::decode (my $decname = $filename);
1067 warn sprintf "loading %s (%d)\n", 1149 warn sprintf "loading %s (%d,%d)\n",
1068 $filename, length $data, scalar @{$av || []}; 1150 $decname, length $data, scalar @{$av || []};
1151
1069 return ($data, $av); 1152 ($data, $av)
1070} 1153}
1071 1154
1072=head2 COMMAND CALLBACKS 1155=head2 COMMAND CALLBACKS
1073 1156
1074=over 4 1157=over 4
… …
1260 1343
1261=head3 cf::player 1344=head3 cf::player
1262 1345
1263=over 4 1346=over 4
1264 1347
1348=item cf::player::num_playing
1349
1350Returns the official number of playing players, as per the Crossfire metaserver rules.
1351
1352=cut
1353
1354sub num_playing {
1355 scalar grep
1356 $_->ob->map
1357 && !$_->hidden
1358 && !$_->ob->flag (cf::FLAG_WIZ),
1359 cf::player::list
1360}
1361
1265=item cf::player::find $login 1362=item cf::player::find $login
1266 1363
1267Returns the given player object, loading it if necessary (might block). 1364Returns the given player object, loading it if necessary (might block).
1268 1365
1269=cut 1366=cut
… …
1304 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst"; 1401 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1305 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata"; 1402 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1306 aio_unlink +(playerdir $login) . "/$login.pl.pst"; 1403 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1307 aio_unlink +(playerdir $login) . "/$login.pl"; 1404 aio_unlink +(playerdir $login) . "/$login.pl";
1308 1405
1309 my $pl = load_pl path $login 1406 my $f = new_from_file cf::object::thawer path $login
1310 or return; 1407 or return;
1408
1409 my $pl = cf::player::load_pl $f
1410 or return;
1411 local $cf::PLAYER_LOADING{$login} = $pl;
1412 $f->resolve_delayed_derefs;
1311 $cf::PLAYER{$login} = $pl 1413 $cf::PLAYER{$login} = $pl
1312 } 1414 }
1313 } 1415 }
1314} 1416}
1315 1417
… …
1463 1565
1464Expand crossfire pod fragments into protocol xml. 1566Expand crossfire pod fragments into protocol xml.
1465 1567
1466=cut 1568=cut
1467 1569
1570use re 'eval';
1571
1572my $group;
1573my $interior; $interior = qr{
1574 # match a pod interior sequence sans C<< >>
1575 (?:
1576 \ (.*?)\ (?{ $group = $^N })
1577 | < (??{$interior}) >
1578 )
1579}x;
1580
1468sub expand_cfpod { 1581sub expand_cfpod {
1469 ((my $self), (local $_)) = @_; 1582 my ($self, $pod) = @_;
1470 1583
1471 # escape & and < 1584 my $xml;
1472 s/&/&amp;/g;
1473 s/(?<![BIUGHT])</&lt;/g;
1474 1585
1475 # this is buggy, it needs to properly take care of nested <'s 1586 while () {
1587 if ($pod =~ /\G( (?: [^BCGHITU]+ | .(?!<) )+ )/xgcs) {
1588 $group = $1;
1476 1589
1477 1 while 1590 $group =~ s/&/&amp;/g;
1478 # replace B<>, I<>, U<> etc. 1591 $group =~ s/</&lt;/g;
1479 s/B<([^\>]*)>/<b>$1<\/b>/ 1592
1480 || s/I<([^\>]*)>/<i>$1<\/i>/ 1593 $xml .= $group;
1481 || s/U<([^\>]*)>/<u>$1<\/u>/ 1594 } elsif ($pod =~ m%\G
1482 || s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/ 1595 ([BCGHITU])
1483 # replace G<male|female> tags 1596 <
1484 || s{G<([^>|]*)\|([^>]*)>}{ 1597 (?:
1485 $self->gender ? $2 : $1 1598 ([^<>]*) (?{ $group = $^N })
1486 }ge 1599 | < $interior >
1487 # replace H<hint text> 1600 )
1488 || s{H<([^\>]*)>} 1601 >
1602 %gcsx
1489 { 1603 ) {
1604 my ($code, $data) = ($1, $group);
1605
1606 if ($code eq "B") {
1607 $xml .= "<b>" . expand_cfpod ($self, $data) . "</b>";
1608 } elsif ($code eq "I") {
1609 $xml .= "<i>" . expand_cfpod ($self, $data) . "</i>";
1610 } elsif ($code eq "U") {
1611 $xml .= "<u>" . expand_cfpod ($self, $data) . "</u>";
1612 } elsif ($code eq "C") {
1613 $xml .= "<tt>" . expand_cfpod ($self, $data) . "</tt>";
1614 } elsif ($code eq "T") {
1615 $xml .= "<big><b>" . expand_cfpod ($self, $data) . "</b></big>";
1616 } elsif ($code eq "G") {
1617 my ($male, $female) = split /\|/, $data;
1618 $data = $self->gender ? $female : $male;
1619 $xml .= expand_cfpod ($self, $data);
1620 } elsif ($code eq "H") {
1490 ("<fg name=\"lightblue\">[$1 (Use hintmode to suppress hints)]</fg>", 1621 $xml .= ("<fg name=\"lightblue\">[" . expand_cfpod ($self, $data) . " (Use hintmode to suppress hints)]</fg>",
1491 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>", 1622 "<fg name=\"lightblue\">[Hint suppressed, see hintmode]</fg>",
1492 "") 1623 "")
1493 [$self->{hintmode}] 1624 [$self->{hintmode}];
1625 } else {
1626 $xml .= "error processing '$code($data)' directive";
1494 }ge; 1627 }
1628 } else {
1629 if ($pod =~ /\G(.+)/) {
1630 warn "parse error while expanding $pod (at $1)";
1631 }
1632 last;
1633 }
1634 }
1495 1635
1636 for ($xml) {
1496 # create single paragraphs (very hackish) 1637 # create single paragraphs (very hackish)
1497 s/(?<=\S)\n(?=\w)/ /g; 1638 s/(?<=\S)\n(?=\w)/ /g;
1498 1639
1499 # compress some whitespace 1640 # compress some whitespace
1500 s/\s+\n/\n/g; # ws line-ends 1641 s/\s+\n/\n/g; # ws line-ends
1501 s/\n\n+/\n/g; # double lines 1642 s/\n\n+/\n/g; # double lines
1502 s/^\n+//; # beginning lines 1643 s/^\n+//; # beginning lines
1503 s/\n+$//; # ending lines 1644 s/\n+$//; # ending lines
1645 }
1504 1646
1505 $_ 1647 $xml
1506} 1648}
1649
1650no re 'eval';
1507 1651
1508sub hintmode { 1652sub hintmode {
1509 $_[0]{hintmode} = $_[1] if @_ > 1; 1653 $_[0]{hintmode} = $_[1] if @_ > 1;
1510 $_[0]{hintmode} 1654 $_[0]{hintmode}
1511} 1655}
… …
1755 1899
1756sub load_header_from($) { 1900sub load_header_from($) {
1757 my ($self, $path) = @_; 1901 my ($self, $path) = @_;
1758 1902
1759 utf8::encode $path; 1903 utf8::encode $path;
1760 #aio_open $path, O_RDONLY, 0 1904 my $f = new_from_file cf::object::thawer $path
1761 # or return;
1762
1763 $self->_load_header ($path)
1764 or return; 1905 or return;
1906
1907 $self->_load_header ($f)
1908 or return;
1909
1910 local $MAP_LOADING{$self->{path}} = $self;
1911 $f->resolve_delayed_derefs;
1765 1912
1766 $self->{load_path} = $path; 1913 $self->{load_path} = $path;
1767 1914
1768 1 1915 1
1769} 1916}
… …
1823sub find { 1970sub find {
1824 my ($path, $origin) = @_; 1971 my ($path, $origin) = @_;
1825 1972
1826 $path = normalise $path, $origin && $origin->path; 1973 $path = normalise $path, $origin && $origin->path;
1827 1974
1975 cf::lock_wait "map_data:$path";#d#remove
1828 cf::lock_wait "map_find:$path"; 1976 cf::lock_wait "map_find:$path";
1829 1977
1830 $cf::MAP{$path} || do { 1978 $cf::MAP{$path} || do {
1831 my $guard = cf::lock_acquire "map_find:$path"; 1979 my $guard1 = cf::lock_acquire "map_find:$path";
1980 my $guard2 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1981
1832 my $map = new_from_path cf::map $path 1982 my $map = new_from_path cf::map $path
1833 or return; 1983 or return;
1834 1984
1835 $map->{last_save} = $cf::RUNTIME; 1985 $map->{last_save} = $cf::RUNTIME;
1836 1986
… …
1838 or return; 1988 or return;
1839 1989
1840 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?) 1990 if ($map->should_reset) {#d#TODO# disabled, crashy (locking issue?)
1841 # doing this can freeze the server in a sync job, obviously 1991 # doing this can freeze the server in a sync job, obviously
1842 #$cf::WAIT_FOR_TICK->wait; 1992 #$cf::WAIT_FOR_TICK->wait;
1993 undef $guard1;
1994 undef $guard2;
1843 $map->reset; 1995 $map->reset;
1844 undef $guard;
1845 return find $path; 1996 return find $path;
1846 } 1997 }
1847 1998
1848 $cf::MAP{$path} = $map 1999 $cf::MAP{$path} = $map
1849 } 2000 }
… …
1858 local $self->{deny_reset} = 1; # loading can take a long time 2009 local $self->{deny_reset} = 1; # loading can take a long time
1859 2010
1860 my $path = $self->{path}; 2011 my $path = $self->{path};
1861 2012
1862 { 2013 {
1863 my $guard1 = cf::lock_acquire "map_data:$path"; 2014 my $guard = cf::lock_acquire "map_data:$path";
1864 my $guard2 = cf::lock_acquire "map_load:$path";
1865 2015
2016 return unless $self->valid;
1866 return if $self->in_memory != cf::MAP_SWAPPED; 2017 return unless $self->in_memory == cf::MAP_SWAPPED;
1867 2018
1868 $self->in_memory (cf::MAP_LOADING); 2019 $self->in_memory (cf::MAP_LOADING);
1869 2020
1870 $self->alloc; 2021 $self->alloc;
1871 2022
1872 $self->pre_load; 2023 $self->pre_load;
1873 cf::cede_to_tick; 2024 cf::cede_to_tick;
1874 2025
2026 my $f = new_from_file cf::object::thawer $self->{load_path};
2027 $f->skip_block;
1875 $self->_load_objects ($self->{load_path}, 1) 2028 $self->_load_objects ($f)
1876 or return; 2029 or return;
1877 2030
1878 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 2031 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1879 if delete $self->{load_original}; 2032 if delete $self->{load_original};
1880 2033
1881 if (my $uniq = $self->uniq_path) { 2034 if (my $uniq = $self->uniq_path) {
1882 utf8::encode $uniq; 2035 utf8::encode $uniq;
1883 if (aio_open $uniq, O_RDONLY, 0) { 2036 unless (aio_stat $uniq) {
2037 if (my $f = new_from_file cf::object::thawer $uniq) {
1884 $self->clear_unique_items; 2038 $self->clear_unique_items;
1885 $self->_load_objects ($uniq, 0); 2039 $self->_load_objects ($f);
2040 $f->resolve_delayed_derefs;
2041 }
1886 } 2042 }
1887 } 2043 }
2044
2045 $f->resolve_delayed_derefs;
1888 2046
1889 cf::cede_to_tick; 2047 cf::cede_to_tick;
1890 # now do the right thing for maps 2048 # now do the right thing for maps
1891 $self->link_multipart_objects; 2049 $self->link_multipart_objects;
1892 $self->difficulty ($self->estimate_difficulty) 2050 $self->difficulty ($self->estimate_difficulty)
… …
1978 } 2136 }
1979 2137
1980 $MAP_PREFETCH{$path} |= $load; 2138 $MAP_PREFETCH{$path} |= $load;
1981 2139
1982 $MAP_PREFETCHER ||= cf::async { 2140 $MAP_PREFETCHER ||= cf::async {
2141 $Coro::current->{desc} = "map prefetcher";
2142
1983 while (%MAP_PREFETCH) { 2143 while (%MAP_PREFETCH) {
1984 while (my ($k, $v) = each %MAP_PREFETCH) { 2144 while (my ($k, $v) = each %MAP_PREFETCH) {
1985 if (my $map = find $k) { 2145 if (my $map = find $k) {
1986 $map->load if $v; 2146 $map->load if $v;
1987 } 2147 }
… …
2013 return if $self->{deny_save}; 2173 return if $self->{deny_save};
2014 2174
2015 local $self->{last_access} = $self->last_access;#d# 2175 local $self->{last_access} = $self->last_access;#d#
2016 2176
2017 cf::async { 2177 cf::async {
2178 $Coro::current->{desc} = "map player save";
2018 $_->contr->save for $self->players; 2179 $_->contr->save for $self->players;
2019 }; 2180 };
2020 2181
2021 if ($uniq) { 2182 if ($uniq) {
2022 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 2183 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
… …
2036 2197
2037 return if $self->players; 2198 return if $self->players;
2038 return if $self->in_memory != cf::MAP_IN_MEMORY; 2199 return if $self->in_memory != cf::MAP_IN_MEMORY;
2039 return if $self->{deny_save}; 2200 return if $self->{deny_save};
2040 2201
2202 $self->in_memory (cf::MAP_SWAPPED);
2203
2204 $self->deactivate;
2205 $_->clear_links_to ($self) for values %cf::MAP;
2041 $self->clear; 2206 $self->clear;
2042 $self->in_memory (cf::MAP_SWAPPED);
2043} 2207}
2044 2208
2045sub reset_at { 2209sub reset_at {
2046 my ($self) = @_; 2210 my ($self) = @_;
2047 2211
… …
2079 if $uniq; 2243 if $uniq;
2080 } 2244 }
2081 2245
2082 delete $cf::MAP{$self->path}; 2246 delete $cf::MAP{$self->path};
2083 2247
2248 $self->deactivate;
2249 $_->clear_links_to ($self) for values %cf::MAP;
2084 $self->clear; 2250 $self->clear;
2085
2086 $_->clear_links_to ($self) for values %cf::MAP;
2087 2251
2088 $self->unlink_save; 2252 $self->unlink_save;
2089 $self->destroy; 2253 $self->destroy;
2090} 2254}
2091 2255
… …
2192 2356
2193sub inv_recursive { 2357sub inv_recursive {
2194 inv_recursive_ inv $_[0] 2358 inv_recursive_ inv $_[0]
2195} 2359}
2196 2360
2361=item $ref = $ob->ref
2362
2363creates and returns a persistent reference to an objetc that can be stored as a string.
2364
2365=item $ob = cf::object::deref ($refstring)
2366
2367returns the objetc referenced by refstring. may return undef when it cnanot find the object,
2368even if the object actually exists. May block.
2369
2370=cut
2371
2372sub deref {
2373 my ($ref) = @_;
2374
2375 if ($ref =~ m{^player\/(<1\.[0-9a-f]+>)/(.*)$}) {
2376 my ($uuid, $name) = ($1, $2);
2377 my $pl = $cf::PLAYER_LOADING{$name} || cf::player::find $name
2378 or return;
2379 $pl->ob->uuid eq $uuid
2380 or return;
2381
2382 $pl->ob
2383 } else {
2384 warn "$ref: cannot resolve object reference\n";
2385 undef
2386 }
2387}
2388
2197package cf; 2389package cf;
2198 2390
2199=back 2391=back
2200 2392
2201=head3 cf::object::player 2393=head3 cf::object::player
… …
2359 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2551 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2360 2552
2361 $self->enter_link; 2553 $self->enter_link;
2362 2554
2363 (async { 2555 (async {
2556 $Coro::current->{desc} = "player::goto $path $x $y";
2557
2558 # *tag paths override both path and x|y
2559 if ($path =~ /^\*(.*)$/) {
2560 if (my @obs = grep $_->map, ext::map_tags::find $1) {
2561 my $ob = $obs[rand @obs];
2562
2563 # see if we actually can go there
2564 if (@obs = grep !$self->blocked ($_->map, $_->x, $_->y), $ob, $ob->tail) {
2565 $ob = $obs[rand @obs];
2566 } else {
2567 $self->message ("Wow, it's pretty crowded in there.", cf::NDI_UNIQUE | cf::NDI_RED);
2568 }
2569 # else put us there anyways for now #d#
2570
2571 ($path, $x, $y) = ($ob->map, $ob->x, $ob->y);
2572 } else {
2573 ($path, $x, $y) = (undef, undef, undef);
2574 }
2575 }
2576
2364 my $map = eval { 2577 my $map = eval {
2365 my $map = cf::map::find $path; 2578 my $map = defined $path ? cf::map::find $path : undef;
2366 2579
2367 if ($map) { 2580 if ($map) {
2368 $map = $map->customise_for ($self); 2581 $map = $map->customise_for ($self);
2369 $map = $check->($map) if $check && $map; 2582 $map = $check->($map) if $check && $map;
2370 } else { 2583 } else {
2371 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2584 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2372 } 2585 }
2373 2586
2374 $map 2587 $map
2375 }; 2588 };
2376 2589
… …
2429 $rmp->{origin_y} = $exit->y; 2642 $rmp->{origin_y} = $exit->y;
2430 } 2643 }
2431 2644
2432 $rmp->{random_seed} ||= $exit->random_seed; 2645 $rmp->{random_seed} ||= $exit->random_seed;
2433 2646
2434 my $data = cf::to_json $rmp; 2647 my $data = cf::encode_json $rmp;
2435 my $md5 = Digest::MD5::md5_hex $data; 2648 my $md5 = Digest::MD5::md5_hex $data;
2436 my $meta = "$RANDOMDIR/$md5.meta"; 2649 my $meta = "$RANDOMDIR/$md5.meta";
2437 2650
2438 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2651 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
2439 aio_write $fh, 0, (length $data), $data, 0; 2652 aio_write $fh, 0, (length $data), $data, 0;
… …
2466 # if exit is damned, update players death & WoR home-position 2679 # if exit is damned, update players death & WoR home-position
2467 $self->contr->savebed ($slaying, $hp, $sp) 2680 $self->contr->savebed ($slaying, $hp, $sp)
2468 if $exit->flag (FLAG_DAMNED); 2681 if $exit->flag (FLAG_DAMNED);
2469 2682
2470 (async { 2683 (async {
2684 $Coro::current->{desc} = "enter_exit $slaying $hp $sp";
2685
2471 $self->deactivate_recursive; # just to be sure 2686 $self->deactivate_recursive; # just to be sure
2472 unless (eval { 2687 unless (eval {
2473 $self->goto ($slaying, $hp, $sp); 2688 $self->goto ($slaying, $hp, $sp);
2474 2689
2475 1; 2690 1;
… …
2510the message, with C<log> being the default. If C<$color> is negative, suppress 2725the message, with C<log> being the default. If C<$color> is negative, suppress
2511the message unless the client supports the msg packet. 2726the message unless the client supports the msg packet.
2512 2727
2513=cut 2728=cut
2514 2729
2730# non-persistent channels (usually the info channel)
2515our %CHANNEL = ( 2731our %CHANNEL = (
2516 "c/identify" => { 2732 "c/identify" => {
2517 id => "identify", 2733 id => "infobox",
2518 title => "Identify", 2734 title => "Identify",
2519 reply => undef, 2735 reply => undef,
2520 tooltip => "Items recently identified", 2736 tooltip => "Items recently identified",
2521 }, 2737 },
2522 "c/examine" => { 2738 "c/examine" => {
2523 id => "examine", 2739 id => "infobox",
2524 title => "Examine", 2740 title => "Examine",
2525 reply => undef, 2741 reply => undef,
2526 tooltip => "Signs and other items you examined", 2742 tooltip => "Signs and other items you examined",
2527 }, 2743 },
2744 "c/book" => {
2745 id => "infobox",
2746 title => "Book",
2747 reply => undef,
2748 tooltip => "The contents of a note or book",
2749 },
2750 "c/lookat" => {
2751 id => "infobox",
2752 title => "Look",
2753 reply => undef,
2754 tooltip => "What you saw there",
2755 },
2756 "c/who" => {
2757 id => "infobox",
2758 title => "Players",
2759 reply => undef,
2760 tooltip => "Shows players who are currently online",
2761 },
2762 "c/body" => {
2763 id => "infobox",
2764 title => "Body Parts",
2765 reply => undef,
2766 tooltip => "Shows which body parts you posess and are available",
2767 },
2768 "c/uptime" => {
2769 id => "infobox",
2770 title => "Uptime",
2771 reply => undef,
2772 tooltip => "How long the server has been running since last restart",
2773 },
2774 "c/mapinfo" => {
2775 id => "infobox",
2776 title => "Map Info",
2777 reply => undef,
2778 tooltip => "Information related to the maps",
2779 },
2528); 2780);
2529 2781
2530sub cf::client::send_msg { 2782sub cf::client::send_msg {
2531 my ($self, $channel, $msg, $color, @extra) = @_; 2783 my ($self, $channel, $msg, $color, @extra) = @_;
2532 2784
2533 $msg = $self->pl->expand_cfpod ($msg); 2785 $msg = $self->pl->expand_cfpod ($msg);
2534 2786
2535 $color &= cf::NDI_CLIENT_MASK; # just in case... 2787 $color &= cf::NDI_CLIENT_MASK; # just in case...
2536 2788
2537 # check predefined channels, for the benefit of C 2789 # check predefined channels, for the benefit of C
2538 $channel = $CHANNEL{$channel} if $CHANNEL{$channel}; 2790 if ($CHANNEL{$channel}) {
2791 $channel = $CHANNEL{$channel};
2539 2792
2793 $self->ext_msg (channel_info => $channel)
2794 if $self->can_msg;
2795
2796 $channel = $channel->{id};
2797
2540 if (ref $channel) { 2798 } elsif (ref $channel) {
2541 # send meta info to client, if not yet sent 2799 # send meta info to client, if not yet sent
2542 unless (exists $self->{channel}{$channel->{id}}) { 2800 unless (exists $self->{channel}{$channel->{id}}) {
2543 $self->{channel}{$channel->{id}} = $channel; 2801 $self->{channel}{$channel->{id}} = $channel;
2544 $self->ext_msg (channel_info => $channel) 2802 $self->ext_msg (channel_info => $channel)
2545 if $self->can_msg; 2803 if $self->can_msg;
… …
2762=pod 3020=pod
2763 3021
2764The following functions and methods are available within a safe environment: 3022The following functions and methods are available within a safe environment:
2765 3023
2766 cf::object 3024 cf::object
2767 contr pay_amount pay_player map x y force_find force_add 3025 contr pay_amount pay_player map x y force_find force_add destroy
2768 insert remove name archname title slaying race decrease_ob_nr 3026 insert remove name archname title slaying race decrease_ob_nr
2769 3027
2770 cf::object::player 3028 cf::object::player
2771 player 3029 player
2772 3030
… …
2779=cut 3037=cut
2780 3038
2781for ( 3039for (
2782 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y 3040 ["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
2783 insert remove inv name archname title slaying race 3041 insert remove inv name archname title slaying race
2784 decrease_ob_nr)], 3042 decrease_ob_nr destroy)],
2785 ["cf::object::player" => qw(player)], 3043 ["cf::object::player" => qw(player)],
2786 ["cf::player" => qw(peaceful)], 3044 ["cf::player" => qw(peaceful)],
2787 ["cf::map" => qw(trigger)], 3045 ["cf::map" => qw(trigger)],
2788) { 3046) {
2789 no strict 'refs'; 3047 no strict 'refs';
… …
2894 { 3152 {
2895 my $faces = $facedata->{faceinfo}; 3153 my $faces = $facedata->{faceinfo};
2896 3154
2897 while (my ($face, $info) = each %$faces) { 3155 while (my ($face, $info) = each %$faces) {
2898 my $idx = (cf::face::find $face) || cf::face::alloc $face; 3156 my $idx = (cf::face::find $face) || cf::face::alloc $face;
3157
2899 cf::face::set_visibility $idx, $info->{visibility}; 3158 cf::face::set_visibility $idx, $info->{visibility};
2900 cf::face::set_magicmap $idx, $info->{magicmap}; 3159 cf::face::set_magicmap $idx, $info->{magicmap};
2901 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32}; 3160 cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2902 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64}; 3161 cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2903 3162
2904 cf::cede_to_tick; 3163 cf::cede_to_tick;
2905 } 3164 }
2906 3165
2907 while (my ($face, $info) = each %$faces) { 3166 while (my ($face, $info) = each %$faces) {
2908 next unless $info->{smooth}; 3167 next unless $info->{smooth};
3168
2909 my $idx = cf::face::find $face 3169 my $idx = cf::face::find $face
2910 or next; 3170 or next;
3171
2911 if (my $smooth = cf::face::find $info->{smooth}) { 3172 if (my $smooth = cf::face::find $info->{smooth}) {
2912 cf::face::set_smooth $idx, $smooth; 3173 cf::face::set_smooth $idx, $smooth;
2913 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3174 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
2914 } else { 3175 } else {
2915 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3176 warn "smooth face '$info->{smooth}' not found for face '$face'";
… …
2933 { 3194 {
2934 # TODO: for gcfclient pleasure, we should give resources 3195 # TODO: for gcfclient pleasure, we should give resources
2935 # that gcfclient doesn't grok a >10000 face index. 3196 # that gcfclient doesn't grok a >10000 face index.
2936 my $res = $facedata->{resource}; 3197 my $res = $facedata->{resource};
2937 3198
2938 my $soundconf = delete $res->{"res/sound.conf"};
2939
2940 while (my ($name, $info) = each %$res) { 3199 while (my ($name, $info) = each %$res) {
3200 if (defined $info->{type}) {
2941 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3201 my $idx = (cf::face::find $name) || cf::face::alloc $name;
2942 my $data; 3202 my $data;
2943 3203
2944 if ($info->{type} & 1) { 3204 if ($info->{type} & 1) {
2945 # prepend meta info 3205 # prepend meta info
2946 3206
2947 my $meta = $enc->encode ({ 3207 my $meta = $enc->encode ({
2948 name => $name, 3208 name => $name,
2949 %{ $info->{meta} || {} }, 3209 %{ $info->{meta} || {} },
2950 }); 3210 });
2951 3211
2952 $data = pack "(w/a*)*", $meta, $info->{data}; 3212 $data = pack "(w/a*)*", $meta, $info->{data};
3213 } else {
3214 $data = $info->{data};
3215 }
3216
3217 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
3218 cf::face::set_type $idx, $info->{type};
2953 } else { 3219 } else {
2954 $data = $info->{data}; 3220 $RESOURCE{$name} = $info;
2955 } 3221 }
2956 3222
2957 cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
2958 cf::face::set_type $idx, $info->{type};
2959
2960 cf::cede_to_tick; 3223 cf::cede_to_tick;
2961 } 3224 }
2962
2963 if ($soundconf) {
2964 $soundconf = $enc->decode (delete $soundconf->{data});
2965
2966 for (0 .. SOUND_CAST_SPELL_0 - 1) {
2967 my $sound = $soundconf->{compat}[$_]
2968 or next;
2969
2970 my $face = cf::face::find "sound/$sound->[1]";
2971 cf::sound::set $sound->[0] => $face;
2972 cf::sound::old_sound_index $_, $face; # gcfclient-compat
2973 }
2974
2975 while (my ($k, $v) = each %{$soundconf->{event}}) {
2976 my $face = cf::face::find "sound/$v";
2977 cf::sound::set $k => $face;
2978 }
2979 }
2980 } 3225 }
3226
3227 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
2981 3228
2982 1 3229 1
2983} 3230}
3231
3232cf::global->attach (on_resource_update => sub {
3233 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3234 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3235
3236 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3237 my $sound = $soundconf->{compat}[$_]
3238 or next;
3239
3240 my $face = cf::face::find "sound/$sound->[1]";
3241 cf::sound::set $sound->[0] => $face;
3242 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3243 }
3244
3245 while (my ($k, $v) = each %{$soundconf->{event}}) {
3246 my $face = cf::face::find "sound/$v";
3247 cf::sound::set $k => $face;
3248 }
3249 }
3250});
2984 3251
2985register_exticmd fx_want => sub { 3252register_exticmd fx_want => sub {
2986 my ($ns, $want) = @_; 3253 my ($ns, $want) = @_;
2987 3254
2988 while (my ($k, $v) = each %$want) { 3255 while (my ($k, $v) = each %$want) {
… …
3043sub reload_config { 3310sub reload_config {
3044 open my $fh, "<:utf8", "$CONFDIR/config" 3311 open my $fh, "<:utf8", "$CONFDIR/config"
3045 or return; 3312 or return;
3046 3313
3047 local $/; 3314 local $/;
3048 *CFG = YAML::Syck::Load <$fh>; 3315 *CFG = YAML::Load <$fh>;
3049 3316
3050 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3317 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
3051 3318
3052 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3319 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3053 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3320 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
… …
3064sub main { 3331sub main {
3065 # we must not ever block the main coroutine 3332 # we must not ever block the main coroutine
3066 local $Coro::idle = sub { 3333 local $Coro::idle = sub {
3067 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 3334 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3068 (async { 3335 (async {
3069 Event::one_event; 3336 $Coro::current->{desc} = "IDLE BUG HANDLER";
3337 EV::loop EV::LOOP_ONESHOT;
3070 })->prio (Coro::PRIO_MAX); 3338 })->prio (Coro::PRIO_MAX);
3071 }; 3339 };
3072 3340
3073 reload_config; 3341 reload_config;
3074 db_init; 3342 db_init;
3075 load_extensions; 3343 load_extensions;
3076 3344
3077 $TICK_WATCHER->start; 3345 $TICK_WATCHER->start;
3346 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3078 Event::loop; 3347 EV::loop;
3079} 3348}
3080 3349
3081############################################################################# 3350#############################################################################
3082# initialisation and cleanup 3351# initialisation and cleanup
3083 3352
3084# install some emergency cleanup handlers 3353# install some emergency cleanup handlers
3085BEGIN { 3354BEGIN {
3355 our %SIGWATCHER = ();
3086 for my $signal (qw(INT HUP TERM)) { 3356 for my $signal (qw(INT HUP TERM)) {
3087 Event->signal ( 3357 $SIGWATCHER{$signal} = EV::signal $signal, sub {
3088 reentrant => 0,
3089 data => WF_AUTOCANCEL,
3090 signal => $signal,
3091 prio => 0,
3092 cb => sub {
3093 cf::cleanup "SIG$signal"; 3358 cf::cleanup "SIG$signal";
3094 },
3095 ); 3359 };
3096 } 3360 }
3097} 3361}
3098 3362
3099sub write_runtime { 3363sub write_runtime {
3100 my $runtime = "$LOCALDIR/runtime"; 3364 my $runtime = "$LOCALDIR/runtime";
… …
3145 # and maps saved/destroyed asynchronously. 3409 # and maps saved/destroyed asynchronously.
3146 warn "begin emergency player save\n"; 3410 warn "begin emergency player save\n";
3147 for my $login (keys %cf::PLAYER) { 3411 for my $login (keys %cf::PLAYER) {
3148 my $pl = $cf::PLAYER{$login} or next; 3412 my $pl = $cf::PLAYER{$login} or next;
3149 $pl->valid or next; 3413 $pl->valid or next;
3414 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3150 $pl->save; 3415 $pl->save;
3151 } 3416 }
3152 warn "end emergency player save\n"; 3417 warn "end emergency player save\n";
3153 3418
3154 warn "begin emergency map save\n"; 3419 warn "begin emergency map save\n";
… …
3193 warn "syncing database to disk"; 3458 warn "syncing database to disk";
3194 BDB::db_env_txn_checkpoint $DB_ENV; 3459 BDB::db_env_txn_checkpoint $DB_ENV;
3195 3460
3196 # if anything goes wrong in here, we should simply crash as we already saved 3461 # if anything goes wrong in here, we should simply crash as we already saved
3197 3462
3198 warn "cancelling all WF_AUTOCANCEL watchers";
3199 for (Event::all_watchers) {
3200 $_->cancel if $_->data & WF_AUTOCANCEL;
3201 }
3202
3203 warn "flushing outstanding aio requests"; 3463 warn "flushing outstanding aio requests";
3204 for (;;) { 3464 for (;;) {
3205 BDB::flush; 3465 BDB::flush;
3206 IO::AIO::flush; 3466 IO::AIO::flush;
3207 Coro::cede; 3467 Coro::cede_notself;
3208 last unless IO::AIO::nreqs || BDB::nreqs; 3468 last unless IO::AIO::nreqs || BDB::nreqs;
3209 warn "iterate..."; 3469 warn "iterate...";
3210 } 3470 }
3211 3471
3212 ++$RELOAD; 3472 ++$RELOAD;
… …
3301 3561
3302sub reload_perl() { 3562sub reload_perl() {
3303 # doing reload synchronously and two reloads happen back-to-back, 3563 # doing reload synchronously and two reloads happen back-to-back,
3304 # coro crashes during coro_state_free->destroy here. 3564 # coro crashes during coro_state_free->destroy here.
3305 3565
3306 $RELOAD_WATCHER ||= Event->timer ( 3566 $RELOAD_WATCHER ||= EV::timer 0, 0, sub {
3307 reentrant => 0,
3308 after => 0,
3309 data => WF_AUTOCANCEL,
3310 cb => sub {
3311 do_reload_perl;
3312 undef $RELOAD_WATCHER; 3567 undef $RELOAD_WATCHER;
3313 }, 3568 do_reload_perl;
3314 ); 3569 };
3315} 3570}
3316 3571
3317register_command "reload" => sub { 3572register_command "reload" => sub {
3318 my ($who, $arg) = @_; 3573 my ($who, $arg) = @_;
3319 3574
3320 if ($who->flag (FLAG_WIZ)) { 3575 if ($who->flag (FLAG_WIZ)) {
3321 $who->message ("reloading server."); 3576 $who->message ("reloading server.");
3577 async {
3578 $Coro::current->{desc} = "perl_reload";
3322 async { reload_perl }; 3579 reload_perl;
3580 };
3323 } 3581 }
3324}; 3582};
3325 3583
3326unshift @INC, $LIBDIR; 3584unshift @INC, $LIBDIR;
3327 3585
… …
3346 my $signal = new Coro::Signal; 3604 my $signal = new Coro::Signal;
3347 push @WAIT_FOR_TICK_BEGIN, $signal; 3605 push @WAIT_FOR_TICK_BEGIN, $signal;
3348 $signal->wait; 3606 $signal->wait;
3349} 3607}
3350 3608
3351 my $min = 1e6;#d# 3609$TICK_WATCHER = EV::periodic_ns 0, $TICK, 0, sub {
3352 my $avg = 10;
3353$TICK_WATCHER = Event->timer (
3354 reentrant => 0,
3355 parked => 1,
3356 prio => 0,
3357 at => $NEXT_TICK || $TICK,
3358 data => WF_AUTOCANCEL,
3359 cb => sub {
3360 if ($Coro::current != $Coro::main) { 3610 if ($Coro::current != $Coro::main) {
3361 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 3611 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
3362 unless ++$bug_warning > 10; 3612 unless ++$bug_warning > 10;
3363 return; 3613 return;
3364 } 3614 }
3365 3615
3366 $NOW = $tick_start = Event::time; 3616 $NOW = $tick_start = EV::now;
3367 3617
3368 cf::server_tick; # one server iteration 3618 cf::server_tick; # one server iteration
3369 3619
3370 0 && sync_job {#d# 3620 $RUNTIME += $TICK;
3371 for(1..10) { 3621 $NEXT_TICK = $_[0]->at;
3372 my $t = Event::time;
3373 my $map = my $map = new_from_path cf::map "/tmp/x.map"
3374 or die;
3375 3622
3376 $map->width (50); 3623 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3377 $map->height (50); 3624 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3378 $map->alloc; 3625 Coro::async_pool {
3379 $map->_load_objects ("/tmp/x.map", 1); 3626 $Coro::current->{desc} = "runtime saver";
3380 my $t = Event::time - $t; 3627 write_runtime
3381 3628 or warn "ERROR: unable to write runtime file: $!";
3382 #next unless $t < 0.0013;#d#
3383 if ($t < $min) {
3384 $min = $t;
3385 }
3386 $avg = $avg * 0.99 + $t * 0.01;
3387 }
3388 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
3389 exit 0;
3390 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
3391 }; 3629 };
3630 }
3392 3631
3393 $RUNTIME += $TICK;
3394 $NEXT_TICK += $TICK;
3395
3396 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3397 $NEXT_RUNTIME_WRITE = $NOW + 10;
3398 Coro::async_pool {
3399 write_runtime
3400 or warn "ERROR: unable to write runtime file: $!";
3401 };
3402 }
3403
3404# my $AFTER = Event::time;
3405# warn $AFTER - $NOW;#d#
3406
3407 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 3632 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3408 $sig->send; 3633 $sig->send;
3409 } 3634 }
3410 while (my $sig = shift @WAIT_FOR_TICK) { 3635 while (my $sig = shift @WAIT_FOR_TICK) {
3411 $sig->send; 3636 $sig->send;
3412 } 3637 }
3413 3638
3414 $NOW = Event::time;
3415
3416 # if we are delayed by four ticks or more, skip them all
3417 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
3418
3419 $TICK_WATCHER->at ($NEXT_TICK);
3420 $TICK_WATCHER->start;
3421
3422 $LOAD = ($NOW - $tick_start) / $TICK; 3639 $LOAD = ($NOW - $tick_start) / $TICK;
3423 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25; 3640 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
3424 3641
3425 _post_tick; 3642 _post_tick;
3426 3643};
3427 3644$TICK_WATCHER->priority (EV::MAXPRI);
3428 },
3429);
3430 3645
3431{ 3646{
3432 BDB::max_poll_time $TICK * 0.1; 3647 # configure BDB
3433 $BDB_POLL_WATCHER = Event->io ( 3648
3434 reentrant => 0,
3435 fd => BDB::poll_fileno,
3436 poll => 'r',
3437 prio => 0,
3438 data => WF_AUTOCANCEL,
3439 cb => \&BDB::poll_cb,
3440 );
3441 BDB::min_parallel 8; 3649 BDB::min_parallel 8;
3442 3650 BDB::max_poll_reqs $TICK * 0.1;
3443 BDB::set_sync_prepare { 3651 $Coro::BDB::WATCHER->priority (1);
3444 my $status;
3445 my $current = $Coro::current;
3446 (
3447 sub {
3448 $status = $!;
3449 $current->ready; undef $current;
3450 },
3451 sub {
3452 Coro::schedule while defined $current;
3453 $! = $status;
3454 },
3455 )
3456 };
3457 3652
3458 unless ($DB_ENV) { 3653 unless ($DB_ENV) {
3459 $DB_ENV = BDB::db_env_create; 3654 $DB_ENV = BDB::db_env_create;
3655 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC
3656 | BDB::LOG_AUTOREMOVE, 1);
3657 $DB_ENV->set_timeout (30, BDB::SET_TXN_TIMEOUT);
3658 $DB_ENV->set_timeout (30, BDB::SET_LOCK_TIMEOUT);
3460 3659
3461 cf::sync_job { 3660 cf::sync_job {
3462 eval { 3661 eval {
3463 BDB::db_env_open 3662 BDB::db_env_open
3464 $DB_ENV, 3663 $DB_ENV,
… …
3466 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 3665 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
3467 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 3666 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
3468 0666; 3667 0666;
3469 3668
3470 cf::cleanup "db_env_open($BDBDIR): $!" if $!; 3669 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
3471
3472 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
3473 $DB_ENV->set_lk_detect;
3474 }; 3670 };
3475 3671
3476 cf::cleanup "db_env_open(db): $@" if $@; 3672 cf::cleanup "db_env_open(db): $@" if $@;
3477 }; 3673 };
3478 } 3674 }
3675
3676 $BDB_DEADLOCK_WATCHER = EV::periodic 0, 3, 0, sub {
3677 BDB::db_env_lock_detect $DB_ENV, 0, BDB::LOCK_DEFAULT, 0, sub { };
3678 };
3679 $BDB_CHECKPOINT_WATCHER = EV::periodic 0, 60, 0, sub {
3680 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
3681 };
3682 $BDB_TRICKLE_WATCHER = EV::periodic 0, 10, 0, sub {
3683 BDB::db_env_memp_trickle $DB_ENV, 20, 0, sub { };
3684 };
3479} 3685}
3480 3686
3481{ 3687{
3688 # configure IO::AIO
3689
3482 IO::AIO::min_parallel 8; 3690 IO::AIO::min_parallel 8;
3483
3484 undef $Coro::AIO::WATCHER;
3485 IO::AIO::max_poll_time $TICK * 0.1; 3691 IO::AIO::max_poll_time $TICK * 0.1;
3486 $AIO_POLL_WATCHER = Event->io ( 3692 $Coro::AIO::WATCHER->priority (1);
3487 reentrant => 0,
3488 data => WF_AUTOCANCEL,
3489 fd => IO::AIO::poll_fileno,
3490 poll => 'r',
3491 prio => 6,
3492 cb => \&IO::AIO::poll_cb,
3493 );
3494} 3693}
3495 3694
3496my $_log_backtrace; 3695my $_log_backtrace;
3497 3696
3498sub _log_backtrace { 3697sub _log_backtrace {
… …
3502 3701
3503 # limit the # of concurrent backtraces 3702 # limit the # of concurrent backtraces
3504 if ($_log_backtrace < 2) { 3703 if ($_log_backtrace < 2) {
3505 ++$_log_backtrace; 3704 ++$_log_backtrace;
3506 async { 3705 async {
3706 $Coro::current->{desc} = "abt $msg";
3707
3507 my @bt = fork_call { 3708 my @bt = fork_call {
3508 @addr = map { sprintf "%x", $_ } @addr; 3709 @addr = map { sprintf "%x", $_ } @addr;
3509 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X; 3710 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3510 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |" 3711 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3511 or die "addr2line: $!"; 3712 or die "addr2line: $!";

Diff Legend

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