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.516 by root, Thu Apr 15 06:05:52 2010 UTC vs.
Revision 1.560 by root, Fri Apr 22 02:03:12 2011 UTC

… …
20# The authors can be reached via e-mail to <support@deliantra.net> 20# The authors can be reached via e-mail to <support@deliantra.net>
21# 21#
22 22
23package cf; 23package cf;
24 24
25use 5.10.0; 25use common::sense;
26use utf8;
27use strict qw(vars subs);
28 26
29use Symbol; 27use Symbol;
30use List::Util; 28use List::Util;
31use Socket; 29use Socket;
32use EV; 30use EV;
… …
78# strictly for debugging 76# strictly for debugging
79$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" }; 77$SIG{QUIT} = sub { Carp::cluck "SIGQUIT" };
80 78
81sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload 79sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
82 80
81our @ORIG_INC;
82
83our %COMMAND = (); 83our %COMMAND = ();
84our %COMMAND_TIME = (); 84our %COMMAND_TIME = ();
85 85
86our @EXTS = (); # list of extension package names 86our @EXTS = (); # list of extension package names
87our %EXTCMD = (); 87our %EXTCMD = ();
… …
93our @EVENT; 93our @EVENT;
94our @REFLECT; # set by XS 94our @REFLECT; # set by XS
95our %REFLECT; # set by us 95our %REFLECT; # set by us
96 96
97our $CONFDIR = confdir; 97our $CONFDIR = confdir;
98
98our $DATADIR = datadir; 99our $DATADIR = datadir;
99our $LIBDIR = "$DATADIR/ext"; 100our $LIBDIR = "$DATADIR/ext";
100our $PODDIR = "$DATADIR/pod"; 101our $PODDIR = "$DATADIR/pod";
101our $MAPDIR = "$DATADIR/" . mapdir; 102our $MAPDIR = "$DATADIR/" . mapdir;
103
102our $LOCALDIR = localdir; 104our $LOCALDIR = localdir;
103our $TMPDIR = "$LOCALDIR/" . tmpdir; 105our $TMPDIR = "$LOCALDIR/" . tmpdir;
104our $UNIQUEDIR = "$LOCALDIR/" . uniquedir; 106our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
105our $PLAYERDIR = "$LOCALDIR/" . playerdir; 107our $PLAYERDIR = "$LOCALDIR/" . playerdir;
106our $RANDOMDIR = "$LOCALDIR/random"; 108our $RANDOMDIR = "$LOCALDIR/random";
107our $BDBDIR = "$LOCALDIR/db"; 109our $BDBDIR = "$LOCALDIR/db";
108our $PIDFILE = "$LOCALDIR/pid"; 110our $PIDFILE = "$LOCALDIR/pid";
109our $RUNTIMEFILE = "$LOCALDIR/runtime"; 111our $RUNTIMEFILE = "$LOCALDIR/runtime";
110 112
111our %RESOURCE; 113our %RESOURCE; # unused
112 114
113our $OUTPUT_RATE_MIN = 4000; 115our $OUTPUT_RATE_MIN = 3000;
114our $OUTPUT_RATE_MAX = 100000; 116our $OUTPUT_RATE_MAX = 1000000;
117
118our $MAX_LINKS = 32; # how many chained exits to follow
119our $VERBOSE_IO = 1;
115 120
116our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!) 121our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
117our $NEXT_RUNTIME_WRITE; # when should the runtime file be written 122our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
118our $NEXT_TICK; 123our $NEXT_TICK;
119our $USE_FSYNC = 1; # use fsync to write maps - default on 124our $USE_FSYNC = 1; # use fsync to write maps - default on
… …
121our $BDB_DEADLOCK_WATCHER; 126our $BDB_DEADLOCK_WATCHER;
122our $BDB_CHECKPOINT_WATCHER; 127our $BDB_CHECKPOINT_WATCHER;
123our $BDB_TRICKLE_WATCHER; 128our $BDB_TRICKLE_WATCHER;
124our $DB_ENV; 129our $DB_ENV;
125 130
126our @EXTRA_MODULES = qw(pod match mapscript); 131our @EXTRA_MODULES = qw(pod match mapscript incloader);
127 132
128our %CFG; 133our %CFG;
129 134
130our $UPTIME; $UPTIME ||= time; 135our $UPTIME; $UPTIME ||= time;
131our $RUNTIME; 136our $RUNTIME;
… …
165 170
166our $EMERGENCY_POSITION; 171our $EMERGENCY_POSITION;
167 172
168sub cf::map::normalise; 173sub cf::map::normalise;
169 174
175sub in_main() {
176 $Coro::current == $Coro::main
177}
178
170############################################################################# 179#############################################################################
171 180
172%REFLECT = (); 181%REFLECT = ();
173for (@REFLECT) { 182for (@REFLECT) {
174 my $reflect = JSON::XS::decode_json $_; 183 my $reflect = JSON::XS::decode_json $_;
… …
226from wherever your confdir points to. 235from wherever your confdir points to.
227 236
228=item cf::wait_for_tick, cf::wait_for_tick_begin 237=item cf::wait_for_tick, cf::wait_for_tick_begin
229 238
230These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only 239These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
231returns directly I<after> the tick processing (and consequently, can only wake one process 240returns directly I<after> the tick processing (and consequently, can only wake one thread
232per tick), while cf::wait_for_tick wakes up all waiters after tick processing. 241per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
242
243=cut
244
245sub wait_for_tick();
246sub wait_for_tick_begin();
233 247
234=item @cf::INVOKE_RESULTS 248=item @cf::INVOKE_RESULTS
235 249
236This array contains the results of the last C<invoke ()> call. When 250This array contains the results of the last C<invoke ()> call. When
237C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of 251C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
… …
245 259
246=back 260=back
247 261
248=cut 262=cut
249 263
264sub error(@) { LOG llevError, join "", @_ }
265sub warn (@) { LOG llevWarn , join "", @_ }
266sub info (@) { LOG llevInfo , join "", @_ }
267sub debug(@) { LOG llevDebug, join "", @_ }
268sub trace(@) { LOG llevTrace, join "", @_ }
269
250$Coro::State::WARNHOOK = sub { 270$Coro::State::WARNHOOK = sub {
251 my $msg = join "", @_; 271 my $msg = join "", @_;
252 272
253 $msg .= "\n" 273 $msg .= "\n"
254 unless $msg =~ /\n$/; 274 unless $msg =~ /\n$/;
255 275
256 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge; 276 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
257 277
258 LOG llevError, $msg; 278 LOG llevWarn, $msg;
259}; 279};
260 280
261$Coro::State::DIEHOOK = sub { 281$Coro::State::DIEHOOK = sub {
262 return unless $^S eq 0; # "eq", not "==" 282 return unless $^S eq 0; # "eq", not "=="
263 283
264 warn Carp::longmess $_[0]; 284 error Carp::longmess $_[0];
265 285
266 if ($Coro::current == $Coro::main) {#d# 286 if (in_main) {#d#
267 warn "DIEHOOK called in main context, Coro bug?\n";#d# 287 error "DIEHOOK called in main context, Coro bug?\n";#d#
268 return;#d# 288 return;#d#
269 }#d# 289 }#d#
270 290
271 # kill coroutine otherwise 291 # kill coroutine otherwise
272 Coro::terminate 292 Coro::terminate
… …
294} 314}
295 315
296$EV::DIED = sub { 316$EV::DIED = sub {
297 Carp::cluck "error in event callback: @_"; 317 Carp::cluck "error in event callback: @_";
298}; 318};
319
320#############################################################################
321
322sub fork_call(&@);
323sub get_slot($;$$);
299 324
300############################################################################# 325#############################################################################
301 326
302=head2 UTILITY FUNCTIONS 327=head2 UTILITY FUNCTIONS
303 328
… …
324 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 349 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
325 $d 350 $d
326 } || "[unable to dump $_[0]: '$@']"; 351 } || "[unable to dump $_[0]: '$@']";
327} 352}
328 353
354=item $scalar = load_file $path
355
356Loads the given file from path and returns its contents. Croaks on error
357and can block.
358
359=cut
360
361sub load_file($) {
362 0 <= aio_load $_[0], my $data
363 or Carp::croak "$_[0]: $!";
364
365 $data
366}
367
329=item $ref = cf::decode_json $json 368=item $ref = cf::decode_json $json
330 369
331Converts a JSON string into the corresponding perl data structure. 370Converts a JSON string into the corresponding perl data structure.
332 371
333=item $json = cf::encode_json $ref 372=item $json = cf::encode_json $ref
… …
339our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max 378our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
340 379
341sub encode_json($) { $json_coder->encode ($_[0]) } 380sub encode_json($) { $json_coder->encode ($_[0]) }
342sub decode_json($) { $json_coder->decode ($_[0]) } 381sub decode_json($) { $json_coder->decode ($_[0]) }
343 382
383=item $ref = cf::decode_storable $scalar
384
385Same as Coro::Storable::thaw, so blocks.
386
387=cut
388
389BEGIN { *decode_storable = \&Coro::Storable::thaw }
390
391=item $ref = cf::decode_yaml $scalar
392
393Same as YAML::XS::Load, but doesn't leak, because it forks (and thus blocks).
394
395=cut
396
397sub decode_yaml($) {
398 fork_call { YAML::XS::Load $_[0] } @_
399}
400
401=item $scalar = cf::unlzf $scalar
402
403Same as Compress::LZF::compress, but takes server ticks into account, so
404blocks.
405
406=cut
407
408sub unlzf($) {
409 # we assume 100mb/s minimum decompression speed (noncompressible data on a ~2ghz machine)
410 cf::get_slot +(length $_[0]) / 100_000_000, 0, "unlzf";
411 Compress::LZF::decompress $_[0]
412}
413
344=item cf::post_init { BLOCK } 414=item cf::post_init { BLOCK }
345 415
346Execute the given codeblock, I<after> all extensions have been (re-)loaded, 416Execute the given codeblock, I<after> all extensions have been (re-)loaded,
347but I<before> the server starts ticking again. 417but I<before> the server starts ticking again.
348 418
349The cdoeblock will have a single boolean argument to indicate whether this 419The codeblock will have a single boolean argument to indicate whether this
350is a reload or not. 420is a reload or not.
351 421
352=cut 422=cut
353 423
354sub post_init(&) { 424sub post_init(&) {
355 push @POST_INIT, shift; 425 push @POST_INIT, shift;
426}
427
428sub _post_init {
429 trace "running post_init jobs";
430
431 # run them in parallel...
432
433 my @join;
434
435 while () {
436 push @join, map &Coro::async ($_, 0), @POST_INIT;
437 @POST_INIT = ();
438
439 @join or last;
440
441 (pop @join)->join;
442 }
356} 443}
357 444
358=item cf::lock_wait $string 445=item cf::lock_wait $string
359 446
360Wait until the given lock is available. See cf::lock_acquire. 447Wait until the given lock is available. See cf::lock_acquire.
… …
413 EV::periodic $start, $interval, 0, $cb 500 EV::periodic $start, $interval, 0, $cb
414} 501}
415 502
416=item cf::get_slot $time[, $priority[, $name]] 503=item cf::get_slot $time[, $priority[, $name]]
417 504
418Allocate $time seconds of blocking CPU time at priority C<$priority>: 505Allocate $time seconds of blocking CPU time at priority C<$priority>
419This call blocks and returns only when you have at least C<$time> seconds 506(default: 0): This call blocks and returns only when you have at least
420of cpu time till the next tick. The slot is only valid till the next cede. 507C<$time> seconds of cpu time till the next tick. The slot is only valid
508till the next cede.
509
510Background jobs should use a priority les than zero, interactive jobs
511should use 100 or more.
421 512
422The optional C<$name> can be used to identify the job to run. It might be 513The optional C<$name> can be used to identify the job to run. It might be
423used for statistical purposes and should identify the same time-class. 514used for statistical purposes and should identify the same time-class.
424 515
425Useful for short background jobs. 516Useful for short background jobs.
… …
505=cut 596=cut
506 597
507sub sync_job(&) { 598sub sync_job(&) {
508 my ($job) = @_; 599 my ($job) = @_;
509 600
510 if ($Coro::current == $Coro::main) { 601 if (in_main) {
511 my $time = AE::time; 602 my $time = AE::time;
512 603
513 # this is the main coro, too bad, we have to block 604 # this is the main coro, too bad, we have to block
514 # till the operation succeeds, freezing the server :/ 605 # till the operation succeeds, freezing the server :/
515 606
516 LOG llevError, Carp::longmess "sync job";#d# 607 #LOG llevError, Carp::longmess "sync job";#d#
517 608
518 my $freeze_guard = freeze_mainloop; 609 my $freeze_guard = freeze_mainloop;
519 610
520 my $busy = 1; 611 my $busy = 1;
521 my @res; 612 my @res;
522 613
523 (async { 614 (async {
524 $Coro::current->desc ("sync job coro"); 615 $Coro::current->desc ("sync job coro");
525 @res = eval { $job->() }; 616 @res = eval { $job->() };
526 warn $@ if $@; 617 error $@ if $@;
527 undef $busy; 618 undef $busy;
528 })->prio (Coro::PRIO_MAX); 619 })->prio (Coro::PRIO_MAX);
529 620
530 while ($busy) { 621 while ($busy) {
531 if (Coro::nready) { 622 if (Coro::nready) {
… …
565 $EXT_CORO{$coro+0} = $coro; 656 $EXT_CORO{$coro+0} = $coro;
566 657
567 $coro 658 $coro
568} 659}
569 660
570=item fork_call { }, $args 661=item fork_call { }, @args
571 662
572Executes the given code block with the given arguments in a seperate 663Executes the given code block with the given arguments in a seperate
573process, returning the results. Everything must be serialisable with 664process, returning the results. Everything must be serialisable with
574Coro::Storable. May, of course, block. Note that the executed sub may 665Coro::Storable. May, of course, block. Note that the executed sub may
575never block itself or use any form of event handling. 666never block itself or use any form of event handling.
576 667
577=cut 668=cut
578 669
670sub post_fork {
671 reset_signals;
672}
673
579sub fork_call(&@) { 674sub fork_call(&@) {
580 my ($cb, @args) = @_; 675 my ($cb, @args) = @_;
581 676
582 # we seemingly have to make a local copy of the whole thing, 677 # we seemingly have to make a local copy of the whole thing,
583 # otherwise perl prematurely frees the stuff :/ 678 # otherwise perl prematurely frees the stuff :/
584 # TODO: investigate and fix (likely this will be rather laborious) 679 # TODO: investigate and fix (likely this will be rather laborious)
585 680
586 my @res = Coro::Util::fork_eval { 681 my @res = Coro::Util::fork_eval {
587 reset_signals; 682 cf::post_fork;
588 &$cb 683 &$cb
589 }, @args; 684 } @args;
590 685
591 wantarray ? @res : $res[-1] 686 wantarray ? @res : $res[-1]
592} 687}
593 688
594sub objinfo { 689sub objinfo {
… …
644within each server. 739within each server.
645 740
646=cut 741=cut
647 742
648sub db_table($) { 743sub db_table($) {
744 cf::error "db_get called from main context"
745 if $Coro::current == $Coro::main;
746
649 my ($name) = @_; 747 my ($name) = @_;
650 my $db = BDB::db_create $DB_ENV; 748 my $db = BDB::db_create $DB_ENV;
651 749
652 eval { 750 eval {
653 $db->set_flags (BDB::CHKSUM); 751 $db->set_flags (BDB::CHKSUM);
… …
663} 761}
664 762
665our $DB; 763our $DB;
666 764
667sub db_init { 765sub db_init {
668 cf::sync_job {
669 $DB ||= db_table "db"; 766 $DB ||= db_table "db";
670 };
671} 767}
672 768
673sub db_get($$) { 769sub db_get($$) {
674 my $key = "$_[0]/$_[1]"; 770 my $key = "$_[0]/$_[1]";
675 771
676 cf::sync_job { 772 cf::error "db_get called from main context"
773 if $Coro::current == $Coro::main;
774
677 BDB::db_get $DB, undef, $key, my $data; 775 BDB::db_get $DB, undef, $key, my $data;
678 776
679 $! ? () 777 $! ? ()
680 : $data 778 : $data
681 }
682} 779}
683 780
684sub db_put($$$) { 781sub db_put($$$) {
685 BDB::dbreq_pri 4; 782 BDB::dbreq_pri 4;
686 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { }; 783 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
… …
714 811
715 my @data; 812 my @data;
716 my $md5; 813 my $md5;
717 814
718 for (0 .. $#$src) { 815 for (0 .. $#$src) {
719 0 <= aio_load $src->[$_], $data[$_] 816 $data[$_] = load_file $src->[$_];
720 or Carp::croak "$src->[$_]: $!";
721 } 817 }
722 818
723 # if processing is expensive, check 819 # if processing is expensive, check
724 # checksum first 820 # checksum first
725 if (1) { 821 if (1) {
… …
742 838
743 my $t1 = Time::HiRes::time; 839 my $t1 = Time::HiRes::time;
744 my $data = $process->(\@data); 840 my $data = $process->(\@data);
745 my $t2 = Time::HiRes::time; 841 my $t2 = Time::HiRes::time;
746 842
747 warn "cache: '$id' processed in ", $t2 - $t1, "s\n"; 843 info "cache: '$id' processed in ", $t2 - $t1, "s\n";
748 844
749 db_put cache => "$id/data", $data; 845 db_put cache => "$id/data", $data;
750 db_put cache => "$id/md5" , $md5; 846 db_put cache => "$id/md5" , $md5;
751 db_put cache => "$id/meta", $meta; 847 db_put cache => "$id/meta", $meta;
752 848
… …
762 858
763=cut 859=cut
764 860
765sub datalog($@) { 861sub datalog($@) {
766 my ($type, %kv) = @_; 862 my ($type, %kv) = @_;
767 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type }); 863 info "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
768} 864}
769 865
770=back 866=back
771 867
772=cut 868=cut
… …
967 1063
968 } elsif (exists $cb_id{$type}) { 1064 } elsif (exists $cb_id{$type}) {
969 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg; 1065 _attach_cb $registry, $cb_id{$type}, $prio, shift @arg;
970 1066
971 } elsif (ref $type) { 1067 } elsif (ref $type) {
972 warn "attaching objects not supported, ignoring.\n"; 1068 error "attaching objects not supported, ignoring.\n";
973 1069
974 } else { 1070 } else {
975 shift @arg; 1071 shift @arg;
976 warn "attach argument '$type' not supported, ignoring.\n"; 1072 error "attach argument '$type' not supported, ignoring.\n";
977 } 1073 }
978 } 1074 }
979} 1075}
980 1076
981sub _object_attach { 1077sub _object_attach {
… …
991 _attach $registry, $klass, @attach; 1087 _attach $registry, $klass, @attach;
992 } 1088 }
993 1089
994 $obj->{$name} = \%arg; 1090 $obj->{$name} = \%arg;
995 } else { 1091 } else {
996 warn "object uses attachment '$name' which is not available, postponing.\n"; 1092 info "object uses attachment '$name' which is not available, postponing.\n";
997 } 1093 }
998 1094
999 $obj->{_attachment}{$name} = undef; 1095 $obj->{_attachment}{$name} = undef;
1000} 1096}
1001 1097
… …
1060 1156
1061 for (@$callbacks) { 1157 for (@$callbacks) {
1062 eval { &{$_->[1]} }; 1158 eval { &{$_->[1]} };
1063 1159
1064 if ($@) { 1160 if ($@) {
1065 warn "$@";
1066 warn "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n"; 1161 error "$@", "... while processing $EVENT[$event][0](@_) event, skipping processing altogether.\n";
1067 override; 1162 override;
1068 } 1163 }
1069 1164
1070 return 1 if $override; 1165 return 1 if $override;
1071 } 1166 }
… …
1150 for (@$attach) { 1245 for (@$attach) {
1151 my ($klass, @attach) = @$_; 1246 my ($klass, @attach) = @$_;
1152 _attach $registry, $klass, @attach; 1247 _attach $registry, $klass, @attach;
1153 } 1248 }
1154 } else { 1249 } else {
1155 warn "object uses attachment '$name' that is not available, postponing.\n"; 1250 info "object uses attachment '$name' that is not available, postponing.\n";
1156 } 1251 }
1157 } 1252 }
1158} 1253}
1159 1254
1160cf::attachable->attach ( 1255cf::attachable->attach (
… …
1187 my ($filename, $rdata, $objs) = @_; 1282 my ($filename, $rdata, $objs) = @_;
1188 1283
1189 sync_job { 1284 sync_job {
1190 if (length $$rdata) { 1285 if (length $$rdata) {
1191 utf8::decode (my $decname = $filename); 1286 utf8::decode (my $decname = $filename);
1192 warn sprintf "saving %s (%d,%d)\n", 1287 trace sprintf "saving %s (%d,%d)\n",
1193 $decname, length $$rdata, scalar @$objs; 1288 $decname, length $$rdata, scalar @$objs
1289 if $VERBOSE_IO;
1194 1290
1195 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 1291 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
1196 aio_chmod $fh, SAVE_MODE; 1292 aio_chmod $fh, SAVE_MODE;
1197 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 1293 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1198 if ($cf::USE_FSYNC) { 1294 if ($cf::USE_FSYNC) {
… …
1220 aio_rename "$filename~", $filename; 1316 aio_rename "$filename~", $filename;
1221 1317
1222 $filename =~ s%/[^/]+$%%; 1318 $filename =~ s%/[^/]+$%%;
1223 aio_pathsync $filename if $cf::USE_FSYNC; 1319 aio_pathsync $filename if $cf::USE_FSYNC;
1224 } else { 1320 } else {
1225 warn "unable to save objects: $filename~: $!\n"; 1321 error "unable to save objects: $filename~: $!\n";
1226 } 1322 }
1227 } else { 1323 } else {
1228 aio_unlink $filename; 1324 aio_unlink $filename;
1229 aio_unlink "$filename.pst"; 1325 aio_unlink "$filename.pst";
1230 } 1326 }
… …
1254 my $st = eval { Coro::Storable::thaw $av }; 1350 my $st = eval { Coro::Storable::thaw $av };
1255 $av = $st->{objs}; 1351 $av = $st->{objs};
1256 } 1352 }
1257 1353
1258 utf8::decode (my $decname = $filename); 1354 utf8::decode (my $decname = $filename);
1259 warn sprintf "loading %s (%d,%d)\n", 1355 trace sprintf "loading %s (%d,%d)\n",
1260 $decname, length $data, scalar @{$av || []}; 1356 $decname, length $data, scalar @{$av || []}
1357 if $VERBOSE_IO;
1261 1358
1262 ($data, $av) 1359 ($data, $av)
1263} 1360}
1264 1361
1265=head2 COMMAND CALLBACKS 1362=head2 COMMAND CALLBACKS
… …
1357 1454
1358 $pl->ext_reply ($reply, @reply) 1455 $pl->ext_reply ($reply, @reply)
1359 if $reply; 1456 if $reply;
1360 1457
1361 } else { 1458 } else {
1362 warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n"; 1459 error "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1363 } 1460 }
1364 1461
1365 cf::override; 1462 cf::override;
1366 }, 1463 },
1367); 1464);
… …
1378 1475
1379 $grp 1476 $grp
1380} 1477}
1381 1478
1382sub load_extensions { 1479sub load_extensions {
1480 info "loading extensions...";
1481
1383 cf::sync_job { 1482 cf::sync_job {
1384 my %todo; 1483 my %todo;
1385 1484
1386 for my $path (<$LIBDIR/*.ext>) { 1485 for my $path (<$LIBDIR/*.ext>) {
1387 next unless -r $path; 1486 next unless -r $path;
… …
1405 1504
1406 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 } 1505 $ext{meta} = { map { (split /=/, $_, 2)[0, 1] } split /\s+/, $1 }
1407 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m; 1506 if $source =~ /\A#!.*?perl.*?#\s*(.*)$/m;
1408 1507
1409 $ext{source} = 1508 $ext{source} =
1410 "package $pkg; use 5.10.0; use strict 'vars', 'subs'; use utf8;\n" 1509 "package $pkg; use common::sense;\n"
1411 . "#line 1 \"$path\"\n{\n" 1510 . "#line 1 \"$path\"\n{\n"
1412 . $source 1511 . $source
1413 . "\n};\n1"; 1512 . "\n};\n1";
1414 1513
1415 $todo{$base} = \%ext; 1514 $todo{$base} = \%ext;
… …
1427 for (split /,\s*/, $v->{meta}{depends}) { 1526 for (split /,\s*/, $v->{meta}{depends}) {
1428 next ext 1527 next ext
1429 unless exists $done{$_}; 1528 unless exists $done{$_};
1430 } 1529 }
1431 1530
1432 warn "... pass $pass, loading '$k' into '$v->{pkg}'\n"; 1531 trace "... pass $pass, loading '$k' into '$v->{pkg}'\n";
1433 1532
1434 my $active = eval $v->{source}; 1533 my $active = eval $v->{source};
1435 1534
1436 if (length $@) { 1535 if (length $@) {
1437 warn "$v->{path}: $@\n"; 1536 error "$v->{path}: $@\n";
1438 1537
1439 cf::cleanup "mandatory extension '$k' failed to load, exiting." 1538 cf::cleanup "mandatory extension '$k' failed to load, exiting."
1440 if exists $v->{meta}{mandatory}; 1539 if exists $v->{meta}{mandatory};
1540
1541 warn "$v->{base}: optional extension cannot be loaded, skipping.\n";
1542 delete $todo{$k};
1441 } else { 1543 } else {
1442 $done{$k} = delete $todo{$k}; 1544 $done{$k} = delete $todo{$k};
1443 push @EXTS, $v->{pkg}; 1545 push @EXTS, $v->{pkg};
1444 $progress = 1; 1546 $progress = 1;
1445 1547
1446 warn "$v->{base}: extension inactive.\n" 1548 info "$v->{base}: extension inactive.\n"
1447 unless $active; 1549 unless $active;
1448 } 1550 }
1449 } 1551 }
1450 1552
1451 unless ($progress) { 1553 unless ($progress) {
… …
1620 my $name = $pl->ob->name; 1722 my $name = $pl->ob->name;
1621 1723
1622 $pl->{deny_save} = 1; 1724 $pl->{deny_save} = 1;
1623 $pl->password ("*"); # this should lock out the player until we have nuked the dir 1725 $pl->password ("*"); # this should lock out the player until we have nuked the dir
1624 1726
1625 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1727 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->ns;
1626 $pl->deactivate; 1728 $pl->deactivate;
1729
1627 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy; 1730 my $killer = cf::arch::get "killer_quit"; $pl->killer ($killer); $killer->destroy;
1628 $pl->ob->check_score;
1629 $pl->invoke (cf::EVENT_PLAYER_QUIT); 1731 $pl->invoke (cf::EVENT_PLAYER_QUIT) if $pl->ns;
1732 ext::highscore::check ($pl->ob);
1733
1630 $pl->ns->destroy if $pl->ns; 1734 $pl->ns->destroy if $pl->ns;
1631 1735
1632 my $path = playerdir $pl; 1736 my $path = playerdir $pl;
1633 my $temp = "$path~$cf::RUNTIME~deleting~"; 1737 my $temp = "$path~$cf::RUNTIME~deleting~";
1634 aio_rename $path, $temp; 1738 aio_rename $path, $temp;
… …
1688 \@logins 1792 \@logins
1689} 1793}
1690 1794
1691=item $player->maps 1795=item $player->maps
1692 1796
1797=item cf::player::maps $login
1798
1693Returns an arrayref of map paths that are private for this 1799Returns an arrayref of map paths that are private for this
1694player. May block. 1800player. May block.
1695 1801
1696=cut 1802=cut
1697 1803
… …
1759=cut 1865=cut
1760 1866
1761sub find_by_path($) { 1867sub find_by_path($) {
1762 my ($path) = @_; 1868 my ($path) = @_;
1763 1869
1870 $path =~ s/^~[^\/]*//; # skip ~login
1871
1764 my ($match, $specificity); 1872 my ($match, $specificity);
1765 1873
1766 for my $region (list) { 1874 for my $region (list) {
1767 if ($region->{match} && $path =~ $region->{match}) { 1875 if ($region->{match} && $path =~ $region->{match}) {
1768 ($match, $specificity) = ($region, $region->specificity) 1876 ($match, $specificity) = ($region, $region->specificity)
… …
1796sub generate_random_map { 1904sub generate_random_map {
1797 my ($self, $rmp) = @_; 1905 my ($self, $rmp) = @_;
1798 1906
1799 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM 1907 my $lock = cf::lock_acquire "generate_random_map"; # the random map generator is NOT reentrant ATM
1800 1908
1801 # mit "rum" bekleckern, nicht
1802 $self->_create_random_map ( 1909 $self->_create_random_map ($rmp);
1803 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1804 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, $rmp->{miningstyle},
1805 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1806 $rmp->{exit_on_final_map},
1807 $rmp->{xsize}, $rmp->{ysize},
1808 $rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1809 $rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1810 $rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1811 $rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1812 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1813 (cf::region::find $rmp->{region}), $rmp->{custom}
1814 )
1815} 1910}
1816 1911
1817=item cf::map->register ($regex, $prio) 1912=item cf::map->register ($regex, $prio)
1818 1913
1819Register a handler for the map path matching the given regex at the 1914Register a handler for the map path matching the given regex at the
… …
1824 1919
1825sub register { 1920sub register {
1826 my (undef, $regex, $prio) = @_; 1921 my (undef, $regex, $prio) = @_;
1827 my $pkg = caller; 1922 my $pkg = caller;
1828 1923
1829 no strict;
1830 push @{"$pkg\::ISA"}, __PACKAGE__; 1924 push @{"$pkg\::ISA"}, __PACKAGE__;
1831 1925
1832 $EXT_MAP{$pkg} = [$prio, qr<$regex>]; 1926 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1833} 1927}
1834 1928
1835# also paths starting with '/' 1929# also paths starting with '/'
1836$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}]; 1930$EXT_MAP{"cf::map::wrap"} = [0, qr{^(?=/)}];
1837 1931
1838sub thawer_merge { 1932sub thawer_merge {
1839 my ($self, $merge) = @_; 1933 my ($self, $merge) = @_;
1840 1934
1841 # we have to keep some variables in memory intact 1935 # we have to keep some variables in memory intact
… …
1846} 1940}
1847 1941
1848sub normalise { 1942sub normalise {
1849 my ($path, $base) = @_; 1943 my ($path, $base) = @_;
1850 1944
1851 $path = "$path"; # make sure its a string 1945 $path = "$path"; # make sure it's a string
1852 1946
1853 $path =~ s/\.map$//; 1947 $path =~ s/\.map$//;
1854 1948
1855 # map plan: 1949 # map plan:
1856 # 1950 #
… …
1871 $base =~ s{[^/]+/?$}{}; 1965 $base =~ s{[^/]+/?$}{};
1872 $path = "$base/$path"; 1966 $path = "$base/$path";
1873 } 1967 }
1874 1968
1875 for ($path) { 1969 for ($path) {
1876 redo if s{//}{/};
1877 redo if s{/\.?/}{/}; 1970 redo if s{/\.?/}{/};
1878 redo if s{/[^/]+/\.\./}{/}; 1971 redo if s{/[^/]+/\.\./}{/};
1879 } 1972 }
1880 1973
1881 $path 1974 $path
… …
1895 $self->init; # pass $1 etc. 1988 $self->init; # pass $1 etc.
1896 return $self; 1989 return $self;
1897 } 1990 }
1898 } 1991 }
1899 1992
1900 Carp::cluck "unable to resolve path '$path' (base '$base')."; 1993 Carp::cluck "unable to resolve path '$path' (base '$base')";
1901 () 1994 ()
1902} 1995}
1903 1996
1904sub init { 1997sub init {
1905 my ($self) = @_; 1998 my ($self) = @_;
… …
2027} 2120}
2028 2121
2029sub find; 2122sub find;
2030sub find { 2123sub find {
2031 my ($path, $origin) = @_; 2124 my ($path, $origin) = @_;
2125
2126 cf::cede_to_tick;
2032 2127
2033 $path = normalise $path, $origin && $origin->path; 2128 $path = normalise $path, $origin && $origin->path;
2034 2129
2035 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove 2130 my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
2036 my $guard2 = cf::lock_acquire "map_find:$path"; 2131 my $guard2 = cf::lock_acquire "map_find:$path";
… …
2121 2216
2122 $self->in_memory (cf::MAP_ACTIVE); 2217 $self->in_memory (cf::MAP_ACTIVE);
2123 } 2218 }
2124 2219
2125 $self->post_load; 2220 $self->post_load;
2221
2222 1
2126} 2223}
2127 2224
2128# customize the map for a given player, i.e. 2225# customize the map for a given player, i.e.
2129# return the _real_ map. used by e.g. per-player 2226# return the _real_ map. used by e.g. per-player
2130# maps to change the path to ~playername/mappath 2227# maps to change the path to ~playername/mappath
… …
2151 or next; 2248 or next;
2152 $neigh = find $neigh, $map 2249 $neigh = find $neigh, $map
2153 or next; 2250 or next;
2154 $neigh->load; 2251 $neigh->load;
2155 2252
2253 # now find the diagonal neighbours
2156 push @neigh, 2254 push @neigh,
2157 [$neigh->tile_path (($_ + 3) % 4), $neigh], 2255 [$neigh->tile_path (($_ + 3) % 4), $neigh],
2158 [$neigh->tile_path (($_ + 1) % 4), $neigh]; 2256 [$neigh->tile_path (($_ + 1) % 4), $neigh];
2159 } 2257 }
2160 2258
… …
2167} 2265}
2168 2266
2169sub find_sync { 2267sub find_sync {
2170 my ($path, $origin) = @_; 2268 my ($path, $origin) = @_;
2171 2269
2172 cf::sync_job { find $path, $origin } 2270 return cf::LOG cf::llevError | cf::logBacktrace, "do_find_sync"
2271 if $Coro::current == $Coro::main;
2272
2273 find $path, $origin
2173} 2274}
2174 2275
2175sub do_load_sync { 2276sub do_load_sync {
2176 my ($map) = @_; 2277 my ($map) = @_;
2177 2278
2178 cf::LOG cf::llevDebug | cf::logBacktrace, "do_load_sync" 2279 return cf::LOG cf::llevError | cf::logBacktrace, "do_load_sync"
2179 if $Coro::current == $Coro::main; 2280 if $Coro::current == $Coro::main;
2180 2281
2181 cf::sync_job { $map->load }; 2282 $map->load;
2182} 2283}
2183 2284
2184our %MAP_PREFETCH; 2285our %MAP_PREFETCH;
2185our $MAP_PREFETCHER = undef; 2286our $MAP_PREFETCHER = undef;
2186 2287
… …
2212 $MAP_PREFETCHER->prio (6); 2313 $MAP_PREFETCHER->prio (6);
2213 2314
2214 () 2315 ()
2215} 2316}
2216 2317
2318# common code, used by both ->save and ->swapout
2217sub save { 2319sub _save {
2218 my ($self) = @_; 2320 my ($self) = @_;
2219
2220 my $lock = cf::lock_acquire "map_data:$self->{path}";
2221 2321
2222 $self->{last_save} = $cf::RUNTIME; 2322 $self->{last_save} = $cf::RUNTIME;
2223 2323
2224 return unless $self->dirty; 2324 return unless $self->dirty;
2225 2325
… …
2245 } else { 2345 } else {
2246 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES); 2346 $self->_save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS | cf::IO_UNIQUES);
2247 } 2347 }
2248} 2348}
2249 2349
2350sub save {
2351 my ($self) = @_;
2352
2353 my $lock = cf::lock_acquire "map_data:$self->{path}";
2354
2355 $self->_save;
2356}
2357
2250sub swap_out { 2358sub swap_out {
2251 my ($self) = @_; 2359 my ($self) = @_;
2252 2360
2253 # save first because save cedes
2254 $self->save;
2255
2256 my $lock = cf::lock_acquire "map_data:$self->{path}"; 2361 my $lock = cf::lock_acquire "map_data:$self->{path}";
2257 2362
2258 return if $self->players;
2259 return if $self->in_memory != cf::MAP_ACTIVE; 2363 return if $self->in_memory != cf::MAP_ACTIVE;
2260 return if $self->{deny_save}; 2364 return if $self->{deny_save};
2365 return if $self->players;
2261 2366
2367 # first deactivate the map and "unlink" it from the core
2368 $self->deactivate;
2369 $_->clear_links_to ($self) for values %cf::MAP;
2262 $self->in_memory (cf::MAP_SWAPPED); 2370 $self->in_memory (cf::MAP_SWAPPED);
2371
2372 # then atomically save
2373 $self->_save;
2374
2375 # then free the map
2376 $self->clear;
2377}
2378
2379sub reset_at {
2380 my ($self) = @_;
2381
2382 # TODO: safety, remove and allow resettable per-player maps
2383 return 1e99 if $self->{deny_reset};
2384
2385 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2386 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2387
2388 $time + $to
2389}
2390
2391sub should_reset {
2392 my ($self) = @_;
2393
2394 $self->reset_at <= $cf::RUNTIME
2395}
2396
2397sub reset {
2398 my ($self) = @_;
2399
2400 my $lock = cf::lock_acquire "map_data:$self->{path}";
2401
2402 return if $self->players;
2403
2404 cf::trace "resetting map ", $self->path, "\n";
2405
2406 $self->in_memory (cf::MAP_SWAPPED);
2407
2408 # need to save uniques path
2409 unless ($self->{deny_save}) {
2410 my $uniq = $self->uniq_path; utf8::encode $uniq;
2411
2412 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2413 if $uniq;
2414 }
2415
2416 delete $cf::MAP{$self->path};
2263 2417
2264 $self->deactivate; 2418 $self->deactivate;
2265 $_->clear_links_to ($self) for values %cf::MAP; 2419 $_->clear_links_to ($self) for values %cf::MAP;
2266 $self->clear; 2420 $self->clear;
2267}
2268
2269sub reset_at {
2270 my ($self) = @_;
2271
2272 # TODO: safety, remove and allow resettable per-player maps
2273 return 1e99 if $self->{deny_reset};
2274
2275 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
2276 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
2277
2278 $time + $to
2279}
2280
2281sub should_reset {
2282 my ($self) = @_;
2283
2284 $self->reset_at <= $cf::RUNTIME
2285}
2286
2287sub reset {
2288 my ($self) = @_;
2289
2290 my $lock = cf::lock_acquire "map_data:$self->{path}";
2291
2292 return if $self->players;
2293
2294 warn "resetting map ", $self->path, "\n";
2295
2296 $self->in_memory (cf::MAP_SWAPPED);
2297
2298 # need to save uniques path
2299 unless ($self->{deny_save}) {
2300 my $uniq = $self->uniq_path; utf8::encode $uniq;
2301
2302 $self->_save_objects ($uniq, cf::IO_UNIQUES)
2303 if $uniq;
2304 }
2305
2306 delete $cf::MAP{$self->path};
2307
2308 $self->deactivate;
2309 $_->clear_links_to ($self) for values %cf::MAP;
2310 $self->clear;
2311 2421
2312 $self->unlink_save; 2422 $self->unlink_save;
2313 $self->destroy; 2423 $self->destroy;
2314} 2424}
2315 2425
… …
2323 2433
2324 delete $cf::MAP{$self->path}; 2434 delete $cf::MAP{$self->path};
2325 2435
2326 $self->unlink_save; 2436 $self->unlink_save;
2327 2437
2328 bless $self, "cf::map"; 2438 bless $self, "cf::map::wrap";
2329 delete $self->{deny_reset}; 2439 delete $self->{deny_reset};
2330 $self->{deny_save} = 1; 2440 $self->{deny_save} = 1;
2331 $self->reset_timeout (1); 2441 $self->reset_timeout (1);
2332 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++)); 2442 $self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2333 2443
… …
2563 2673
2564Freezes the player and moves him/her to a special map (C<{link}>). 2674Freezes the player and moves him/her to a special map (C<{link}>).
2565 2675
2566The player should be reasonably safe there for short amounts of time (e.g. 2676The player should be reasonably safe there for short amounts of time (e.g.
2567for loading a map). You I<MUST> call C<leave_link> as soon as possible, 2677for loading a map). You I<MUST> call C<leave_link> as soon as possible,
2568though, as the palyer cannot control the character while it is on the link 2678though, as the player cannot control the character while it is on the link
2569map. 2679map.
2570 2680
2571Will never block. 2681Will never block.
2572 2682
2573=item $player_object->leave_link ($map, $x, $y) 2683=item $player_object->leave_link ($map, $x, $y)
… …
2594sub cf::object::player::enter_link { 2704sub cf::object::player::enter_link {
2595 my ($self) = @_; 2705 my ($self) = @_;
2596 2706
2597 $self->deactivate_recursive; 2707 $self->deactivate_recursive;
2598 2708
2709 ++$self->{_link_recursion};
2710
2599 return if UNIVERSAL::isa $self->map, "ext::map_link"; 2711 return if UNIVERSAL::isa $self->map, "ext::map_link";
2600 2712
2601 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 2713 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
2602 if $self->map && $self->map->{path} ne "{link}"; 2714 if $self->map && $self->map->{path} ne "{link}";
2603 2715
2604 $self->enter_map ($LINK_MAP || link_map, 10, 10); 2716 $self->enter_map ($LINK_MAP || link_map, 3, 3);
2605} 2717}
2606 2718
2607sub cf::object::player::leave_link { 2719sub cf::object::player::leave_link {
2608 my ($self, $map, $x, $y) = @_; 2720 my ($self, $map, $x, $y) = @_;
2609 2721
… …
2634 $map->load_neighbours; 2746 $map->load_neighbours;
2635 2747
2636 return unless $self->contr->active; 2748 return unless $self->contr->active;
2637 2749
2638 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext 2750 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
2639 $self->enter_map ($map, $x, $y); 2751 if ($self->enter_map ($map, $x, $y)) {
2640 2752 # entering was successful
2753 delete $self->{_link_recursion};
2641 # only activate afterwards, to support waiting in hooks 2754 # only activate afterwards, to support waiting in hooks
2642 $self->activate_recursive; 2755 $self->activate_recursive;
2643} 2756 }
2644 2757
2758}
2759
2645=item $player_object->goto ($path, $x, $y[, $check->($map)[, $done->()]]) 2760=item $player_object->goto ($path, $x, $y[, $check->($map, $x, $y, $player)[, $done->($player)]])
2646 2761
2647Moves the player to the given map-path and coordinates by first freezing 2762Moves the player to the given map-path and coordinates by first freezing
2648her, loading and preparing them map, calling the provided $check callback 2763her, loading and preparing them map, calling the provided $check callback
2649that has to return the map if sucecssful, and then unfreezes the player on 2764that has to return the map if sucecssful, and then unfreezes the player on
2650the new (success) or old (failed) map position. In either case, $done will 2765the new (success) or old (failed) map position. In either case, $done will
… …
2657 2772
2658our $GOTOGEN; 2773our $GOTOGEN;
2659 2774
2660sub cf::object::player::goto { 2775sub cf::object::player::goto {
2661 my ($self, $path, $x, $y, $check, $done) = @_; 2776 my ($self, $path, $x, $y, $check, $done) = @_;
2777
2778 if ($self->{_link_recursion} >= $MAX_LINKS) {
2779 error "FATAL: link recursion exceeded, ", $self->name, " goto $path $x $y, redirecting.";
2780 $self->failmsg ("Something went wrong inside the server - please contact an administrator!");
2781 ($path, $x, $y) = @$EMERGENCY_POSITION;
2782 }
2662 2783
2663 # do generation counting so two concurrent goto's will be executed in-order 2784 # do generation counting so two concurrent goto's will be executed in-order
2664 my $gen = $self->{_goto_generation} = ++$GOTOGEN; 2785 my $gen = $self->{_goto_generation} = ++$GOTOGEN;
2665 2786
2666 $self->enter_link; 2787 $self->enter_link;
… …
2690 my $map = eval { 2811 my $map = eval {
2691 my $map = defined $path ? cf::map::find $path : undef; 2812 my $map = defined $path ? cf::map::find $path : undef;
2692 2813
2693 if ($map) { 2814 if ($map) {
2694 $map = $map->customise_for ($self); 2815 $map = $map->customise_for ($self);
2695 $map = $check->($map) if $check && $map; 2816 $map = $check->($map, $x, $y, $self) if $check && $map;
2696 } else { 2817 } else {
2697 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED); 2818 $self->message ("The exit to '$path' is closed.", cf::NDI_UNIQUE | cf::NDI_RED);
2698 } 2819 }
2699 2820
2700 $map 2821 $map
… …
2708 if ($gen == $self->{_goto_generation}) { 2829 if ($gen == $self->{_goto_generation}) {
2709 delete $self->{_goto_generation}; 2830 delete $self->{_goto_generation};
2710 $self->leave_link ($map, $x, $y); 2831 $self->leave_link ($map, $x, $y);
2711 } 2832 }
2712 2833
2713 $done->() if $done; 2834 $done->($self) if $done;
2714 })->prio (1); 2835 })->prio (1);
2715} 2836}
2716 2837
2717=item $player_object->enter_exit ($exit_object) 2838=item $player_object->enter_exit ($exit_object)
2718 2839
… …
2811 $self->message ("Something went wrong deep within the deliantra server. " 2932 $self->message ("Something went wrong deep within the deliantra server. "
2812 . "I'll try to bring you back to the map you were before. " 2933 . "I'll try to bring you back to the map you were before. "
2813 . "Please report this to the dungeon master!", 2934 . "Please report this to the dungeon master!",
2814 cf::NDI_UNIQUE | cf::NDI_RED); 2935 cf::NDI_UNIQUE | cf::NDI_RED);
2815 2936
2816 warn "ERROR in enter_exit: $@"; 2937 error "ERROR in enter_exit: $@";
2817 $self->leave_link; 2938 $self->leave_link;
2818 } 2939 }
2819 })->prio (1); 2940 })->prio (1);
2820} 2941}
2821 2942
… …
3134 3255
3135 $ns->ext_reply ($reply, @reply) 3256 $ns->ext_reply ($reply, @reply)
3136 if $reply; 3257 if $reply;
3137 3258
3138 } else { 3259 } else {
3139 warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n"; 3260 error "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
3140 } 3261 }
3141 3262
3142 cf::override; 3263 cf::override;
3143 }, 3264 },
3144); 3265);
… …
3225 decrease split destroy change_exp value msg lore send_msg)], 3346 decrease split destroy change_exp value msg lore send_msg)],
3226 ["cf::object::player" => qw(player)], 3347 ["cf::object::player" => qw(player)],
3227 ["cf::player" => qw(peaceful send_msg)], 3348 ["cf::player" => qw(peaceful send_msg)],
3228 ["cf::map" => qw(trigger)], 3349 ["cf::map" => qw(trigger)],
3229) { 3350) {
3230 no strict 'refs';
3231 my ($pkg, @funs) = @$_; 3351 my ($pkg, @funs) = @$_;
3232 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"}) 3352 *{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
3233 for @funs; 3353 for @funs;
3234} 3354}
3235 3355
… …
3274 local @cf::_safe_eval_args = values %vars; 3394 local @cf::_safe_eval_args = values %vars;
3275 @res = wantarray ? eval eval : scalar eval $eval; 3395 @res = wantarray ? eval eval : scalar eval $eval;
3276 } 3396 }
3277 3397
3278 if ($@) { 3398 if ($@) {
3279 warn "$@"; 3399 warn "$@",
3280 warn "while executing safe code '$code'\n"; 3400 "while executing safe code '$code'\n",
3281 warn "with arguments " . (join " ", %vars) . "\n"; 3401 "with arguments " . (join " ", %vars) . "\n";
3282 } 3402 }
3283 3403
3284 wantarray ? @res : $res[0] 3404 wantarray ? @res : $res[0]
3285} 3405}
3286 3406
… …
3320 # for this (global event?) 3440 # for this (global event?)
3321 %ext::player_env::MUSIC_FACE_CACHE = (); 3441 %ext::player_env::MUSIC_FACE_CACHE = ();
3322 3442
3323 my $enc = JSON::XS->new->utf8->canonical->relaxed; 3443 my $enc = JSON::XS->new->utf8->canonical->relaxed;
3324 3444
3325 warn "loading facedata from $path\n"; 3445 trace "loading facedata from $path\n";
3326 3446
3327 my $facedata; 3447 my $facedata = decode_storable load_file $path;
3328 0 < aio_load $path, $facedata
3329 or die "$path: $!";
3330
3331 $facedata = Coro::Storable::thaw $facedata;
3332 3448
3333 $facedata->{version} == 2 3449 $facedata->{version} == 2
3334 or cf::cleanup "$path: version mismatch, cannot proceed."; 3450 or cf::cleanup "$path: version mismatch, cannot proceed.";
3335 3451
3336 # patch in the exptable 3452 # patch in the exptable
… …
3350 3466
3351 cf::face::set_visibility $idx, $info->{visibility}; 3467 cf::face::set_visibility $idx, $info->{visibility};
3352 cf::face::set_magicmap $idx, $info->{magicmap}; 3468 cf::face::set_magicmap $idx, $info->{magicmap};
3353 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32}; 3469 cf::face::set_data $idx, 0, $info->{data32}, $info->{hash32};
3354 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64}; 3470 cf::face::set_data $idx, 1, $info->{data64}, $info->{hash64};
3471 cf::face::set_data $idx, 2, $info->{glyph} , $info->{glyph} ;
3355 3472
3356 cf::cede_to_tick; 3473 cf::cede_to_tick;
3357 } 3474 }
3358 3475
3359 while (my ($face, $info) = each %$faces) { 3476 while (my ($face, $info) = each %$faces) {
… …
3364 3481
3365 if (my $smooth = cf::face::find $info->{smooth}) { 3482 if (my $smooth = cf::face::find $info->{smooth}) {
3366 cf::face::set_smooth $idx, $smooth; 3483 cf::face::set_smooth $idx, $smooth;
3367 cf::face::set_smoothlevel $idx, $info->{smoothlevel}; 3484 cf::face::set_smoothlevel $idx, $info->{smoothlevel};
3368 } else { 3485 } else {
3369 warn "smooth face '$info->{smooth}' not found for face '$face'"; 3486 error "smooth face '$info->{smooth}' not found for face '$face'";
3370 } 3487 }
3371 3488
3372 cf::cede_to_tick; 3489 cf::cede_to_tick;
3373 } 3490 }
3374 } 3491 }
… …
3392 my $idx = (cf::face::find $name) || cf::face::alloc $name; 3509 my $idx = (cf::face::find $name) || cf::face::alloc $name;
3393 3510
3394 cf::face::set_data $idx, 0, $info->{data}, $info->{hash}; 3511 cf::face::set_data $idx, 0, $info->{data}, $info->{hash};
3395 cf::face::set_type $idx, $info->{type}; 3512 cf::face::set_type $idx, $info->{type};
3396 } else { 3513 } else {
3397 $RESOURCE{$name} = $info; 3514 $RESOURCE{$name} = $info; # unused
3398 } 3515 }
3399 3516
3400 cf::cede_to_tick; 3517 cf::cede_to_tick;
3401 } 3518 }
3402 } 3519 }
3403 3520
3404 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE); 3521 cf::global->invoke (EVENT_GLOBAL_RESOURCE_UPDATE);
3405 3522
3406 1 3523 1
3407} 3524}
3408
3409cf::global->attach (on_resource_update => sub {
3410 if (my $soundconf = $RESOURCE{"res/sound.conf"}) {
3411 $soundconf = JSON::XS->new->utf8->relaxed->decode ($soundconf->{data});
3412
3413 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3414 my $sound = $soundconf->{compat}[$_]
3415 or next;
3416
3417 my $face = cf::face::find "sound/$sound->[1]";
3418 cf::sound::set $sound->[0] => $face;
3419 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3420 }
3421
3422 while (my ($k, $v) = each %{$soundconf->{event}}) {
3423 my $face = cf::face::find "sound/$v";
3424 cf::sound::set $k => $face;
3425 }
3426 }
3427});
3428 3525
3429register_exticmd fx_want => sub { 3526register_exticmd fx_want => sub {
3430 my ($ns, $want) = @_; 3527 my ($ns, $want) = @_;
3431 3528
3432 while (my ($k, $v) = each %$want) { 3529 while (my ($k, $v) = each %$want) {
… …
3471sub reload_treasures { 3568sub reload_treasures {
3472 load_resource_file "$DATADIR/treasures" 3569 load_resource_file "$DATADIR/treasures"
3473 or die "unable to load treasurelists\n"; 3570 or die "unable to load treasurelists\n";
3474} 3571}
3475 3572
3573sub reload_sound {
3574 trace "loading sound config from $DATADIR/sound\n";
3575
3576 my $soundconf = JSON::XS->new->utf8->relaxed->decode (load_file "$DATADIR/sound");
3577
3578 for (0 .. SOUND_CAST_SPELL_0 - 1) {
3579 my $sound = $soundconf->{compat}[$_]
3580 or next;
3581
3582 my $face = cf::face::find "sound/$sound->[1]";
3583 cf::sound::set $sound->[0] => $face;
3584 cf::sound::old_sound_index $_, $face; # gcfclient-compat
3585 }
3586
3587 while (my ($k, $v) = each %{$soundconf->{event}}) {
3588 my $face = cf::face::find "sound/$v";
3589 cf::sound::set $k => $face;
3590 }
3591}
3592
3476sub reload_resources { 3593sub reload_resources {
3477 warn "reloading resource files...\n"; 3594 trace "reloading resource files...\n";
3478 3595
3596 reload_exp_table;
3597 reload_materials;
3479 reload_facedata; 3598 reload_facedata;
3599 reload_sound;
3480 reload_archetypes; 3600 reload_archetypes;
3481 reload_regions; 3601 reload_regions;
3482 reload_treasures; 3602 reload_treasures;
3483 3603
3484 warn "finished reloading resource files\n"; 3604 trace "finished reloading resource files\n";
3485} 3605}
3486 3606
3487sub reload_config { 3607sub reload_config {
3488 warn "reloading config file...\n"; 3608 trace "reloading config file...\n";
3489 3609
3490 open my $fh, "<:utf8", "$CONFDIR/config" 3610 my $config = load_file "$CONFDIR/config";
3491 or return; 3611 utf8::decode $config;
3612 *CFG = decode_yaml $config;
3492 3613
3493 local $/;
3494 *CFG = YAML::XS::Load scalar <$fh>;
3495
3496 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37]; 3614 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_104_115", 49, 38];
3497 3615
3498 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset}; 3616 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
3499 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset}; 3617 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
3500 3618
3501 if (exists $CFG{mlockall}) { 3619 if (exists $CFG{mlockall}) {
… …
3503 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 3621 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
3504 and die "WARNING: m(un)lockall failed: $!\n"; 3622 and die "WARNING: m(un)lockall failed: $!\n";
3505 }; 3623 };
3506 warn $@ if $@; 3624 warn $@ if $@;
3507 } 3625 }
3508
3509 warn "finished reloading resource files\n";
3510} 3626}
3511 3627
3512sub pidfile() { 3628sub pidfile() {
3513 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT 3629 sysopen my $fh, $PIDFILE, O_RDWR | O_CREAT
3514 or die "$PIDFILE: $!"; 3630 or die "$PIDFILE: $!";
… …
3527 seek $fh, 0, 0; 3643 seek $fh, 0, 0;
3528 print $fh $$; 3644 print $fh $$;
3529} 3645}
3530 3646
3531sub main_loop { 3647sub main_loop {
3532 warn "EV::loop starting\n"; 3648 trace "EV::loop starting\n";
3533 if (1) { 3649 if (1) {
3534 EV::loop; 3650 EV::loop;
3535 } 3651 }
3536 warn "EV::loop returned\n"; 3652 trace "EV::loop returned\n";
3537 goto &main_loop unless $REALLY_UNLOOP; 3653 goto &main_loop unless $REALLY_UNLOOP;
3538} 3654}
3539 3655
3540sub main { 3656sub main {
3541 cf::init_globals; # initialise logging 3657 cf::init_globals; # initialise logging
3542 3658
3543 LOG llevInfo, "Welcome to Deliantra, v" . VERSION; 3659 LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
3544 LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team."; 3660 LOG llevInfo, "Copyright (C) 2005-2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
3545 LOG llevInfo, "Copyright (C) 1994 Mark Wedel."; 3661 LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
3546 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen."; 3662 LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
3547 3663
3548 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority 3664 $Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3549 3665
… …
3557 }; 3673 };
3558 3674
3559 evthread_start IO::AIO::poll_fileno; 3675 evthread_start IO::AIO::poll_fileno;
3560 3676
3561 cf::sync_job { 3677 cf::sync_job {
3562 cf::init_experience; 3678 cf::incloader::init ();
3679
3563 cf::init_anim; 3680 cf::init_anim;
3564 cf::init_attackmess; 3681 cf::init_attackmess;
3565 cf::init_dynamic; 3682 cf::init_dynamic;
3566 3683
3567 cf::load_settings; 3684 cf::load_settings;
3568 cf::load_materials;
3569 3685
3570 reload_resources; 3686 reload_resources;
3571 reload_config; 3687 reload_config;
3572 db_init; 3688 db_init;
3573 3689
… …
3585 3701
3586 # no (long-running) fork's whatsoever before this point(!) 3702 # no (long-running) fork's whatsoever before this point(!)
3587 use POSIX (); 3703 use POSIX ();
3588 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD}; 3704 POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
3589 3705
3590 (pop @POST_INIT)->(0) while @POST_INIT; 3706 cf::_post_init 0;
3591 }; 3707 };
3592 3708
3593 cf::object::thawer::errors_are_fatal 0; 3709 cf::object::thawer::errors_are_fatal 0;
3710 info "parse errors in files are no longer fatal from this point on.\n";
3594 3711
3712 my $free_main; $free_main = EV::idle sub {
3713 undef $free_main;
3714 undef &main; # free gobs of memory :)
3715 };
3716
3595 main_loop; 3717 goto &main_loop;
3596} 3718}
3597 3719
3598############################################################################# 3720#############################################################################
3599# initialisation and cleanup 3721# initialisation and cleanup
3600 3722
… …
3639 or return; 3761 or return;
3640 3762
3641 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE 3763 aio_rename "$RUNTIMEFILE~", $RUNTIMEFILE
3642 and return; 3764 and return;
3643 3765
3644 warn sprintf "runtime file written (%gs).\n", AE::time - $t0; 3766 trace sprintf "runtime file written (%gs).\n", AE::time - $t0;
3645 3767
3646 1 3768 1
3647} 3769}
3648 3770
3649our $uuid_lock; 3771our $uuid_lock;
… …
3661 or return; 3783 or return;
3662 3784
3663 my $value = uuid_seq uuid_cur; 3785 my $value = uuid_seq uuid_cur;
3664 3786
3665 unless ($value) { 3787 unless ($value) {
3666 warn "cowardly refusing to write zero uuid value!\n"; 3788 info "cowardly refusing to write zero uuid value!\n";
3667 return; 3789 return;
3668 } 3790 }
3669 3791
3670 my $value = uuid_str $value + $uuid_skip; 3792 my $value = uuid_str $value + $uuid_skip;
3671 $uuid_skip = 0; 3793 $uuid_skip = 0;
… …
3681 or return; 3803 or return;
3682 3804
3683 aio_rename "$uuid~", $uuid 3805 aio_rename "$uuid~", $uuid
3684 and return; 3806 and return;
3685 3807
3686 warn "uuid file written ($value).\n"; 3808 trace "uuid file written ($value).\n";
3687 3809
3688 1 3810 1
3689 3811
3690} 3812}
3691 3813
… …
3697} 3819}
3698 3820
3699sub emergency_save() { 3821sub emergency_save() {
3700 my $freeze_guard = cf::freeze_mainloop; 3822 my $freeze_guard = cf::freeze_mainloop;
3701 3823
3702 warn "emergency_perl_save: enter\n"; 3824 info "emergency_perl_save: enter\n";
3825
3826 # this is a trade-off: we want to be very quick here, so
3827 # save all maps without fsync, and later call a global sync
3828 # (which in turn might be very very slow)
3829 local $USE_FSYNC = 0;
3703 3830
3704 cf::sync_job { 3831 cf::sync_job {
3705 # this is a trade-off: we want to be very quick here, so 3832 cf::write_runtime_sync; # external watchdog should not bark
3706 # save all maps without fsync, and later call a global sync
3707 # (which in turn might be very very slow)
3708 local $USE_FSYNC = 0;
3709 3833
3710 # use a peculiar iteration method to avoid tripping on perl 3834 # use a peculiar iteration method to avoid tripping on perl
3711 # refcount bugs in for. also avoids problems with players 3835 # refcount bugs in for. also avoids problems with players
3712 # and maps saved/destroyed asynchronously. 3836 # and maps saved/destroyed asynchronously.
3713 warn "emergency_perl_save: begin player save\n"; 3837 info "emergency_perl_save: begin player save\n";
3714 for my $login (keys %cf::PLAYER) { 3838 for my $login (keys %cf::PLAYER) {
3715 my $pl = $cf::PLAYER{$login} or next; 3839 my $pl = $cf::PLAYER{$login} or next;
3716 $pl->valid or next; 3840 $pl->valid or next;
3717 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt 3841 delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3718 $pl->save; 3842 $pl->save;
3719 } 3843 }
3720 warn "emergency_perl_save: end player save\n"; 3844 info "emergency_perl_save: end player save\n";
3721 3845
3846 cf::write_runtime_sync; # external watchdog should not bark
3847
3722 warn "emergency_perl_save: begin map save\n"; 3848 info "emergency_perl_save: begin map save\n";
3723 for my $path (keys %cf::MAP) { 3849 for my $path (keys %cf::MAP) {
3724 my $map = $cf::MAP{$path} or next; 3850 my $map = $cf::MAP{$path} or next;
3725 $map->valid or next; 3851 $map->valid or next;
3726 $map->save; 3852 $map->save;
3727 } 3853 }
3728 warn "emergency_perl_save: end map save\n"; 3854 info "emergency_perl_save: end map save\n";
3729 3855
3856 cf::write_runtime_sync; # external watchdog should not bark
3857
3730 warn "emergency_perl_save: begin database checkpoint\n"; 3858 info "emergency_perl_save: begin database checkpoint\n";
3731 BDB::db_env_txn_checkpoint $DB_ENV; 3859 BDB::db_env_txn_checkpoint $DB_ENV;
3732 warn "emergency_perl_save: end database checkpoint\n"; 3860 info "emergency_perl_save: end database checkpoint\n";
3733 3861
3734 warn "emergency_perl_save: begin write uuid\n"; 3862 info "emergency_perl_save: begin write uuid\n";
3735 write_uuid_sync 1; 3863 write_uuid_sync 1;
3736 warn "emergency_perl_save: end write uuid\n"; 3864 info "emergency_perl_save: end write uuid\n";
3865
3866 cf::write_runtime_sync; # external watchdog should not bark
3867
3868 trace "emergency_perl_save: syncing database to disk";
3869 BDB::db_env_txn_checkpoint $DB_ENV;
3870
3871 info "emergency_perl_save: starting sync\n";
3872 IO::AIO::aio_sync sub {
3873 info "emergency_perl_save: finished sync\n";
3874 };
3875
3876 cf::write_runtime_sync; # external watchdog should not bark
3877
3878 trace "emergency_perl_save: flushing outstanding aio requests";
3879 while (IO::AIO::nreqs || BDB::nreqs) {
3880 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3881 }
3882
3883 cf::write_runtime_sync; # external watchdog should not bark
3737 }; 3884 };
3738 3885
3739 warn "emergency_perl_save: starting sync()\n";
3740 IO::AIO::aio_sync sub {
3741 warn "emergency_perl_save: finished sync()\n";
3742 };
3743
3744 warn "emergency_perl_save: leave\n"; 3886 info "emergency_perl_save: leave\n";
3745} 3887}
3746 3888
3747sub post_cleanup { 3889sub post_cleanup {
3748 my ($make_core) = @_; 3890 my ($make_core) = @_;
3749 3891
3892 IO::AIO::flush;
3893
3750 warn Carp::longmess "post_cleanup backtrace" 3894 error Carp::longmess "post_cleanup backtrace"
3751 if $make_core; 3895 if $make_core;
3752 3896
3753 my $fh = pidfile; 3897 my $fh = pidfile;
3754 unlink $PIDFILE if <$fh> == $$; 3898 unlink $PIDFILE if <$fh> == $$;
3755} 3899}
… …
3775 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH}; 3919 my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3776 for my $name (keys %$leaf_symtab) { 3920 for my $name (keys %$leaf_symtab) {
3777 _gv_clear *{"$pkg$name"}; 3921 _gv_clear *{"$pkg$name"};
3778# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"}; 3922# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3779 } 3923 }
3780 warn "cleared package $pkg\n";#d#
3781} 3924}
3782 3925
3783sub do_reload_perl() { 3926sub do_reload_perl() {
3784 # can/must only be called in main 3927 # can/must only be called in main
3785 if ($Coro::current != $Coro::main) { 3928 unless (in_main) {
3786 warn "can only reload from main coroutine"; 3929 error "can only reload from main coroutine";
3787 return; 3930 return;
3788 } 3931 }
3789 3932
3790 return if $RELOAD++; 3933 return if $RELOAD++;
3791 3934
3792 my $t1 = AE::time; 3935 my $t1 = AE::time;
3793 3936
3794 while ($RELOAD) { 3937 while ($RELOAD) {
3795 warn "reloading..."; 3938 cf::get_slot 0.1, -1, "reload_perl";
3939 info "perl_reload: reloading...";
3796 3940
3797 warn "entering sync_job"; 3941 trace "perl_reload: entering sync_job";
3798 3942
3799 cf::sync_job { 3943 cf::sync_job {
3800 cf::write_runtime_sync; # external watchdog should not bark
3801 cf::emergency_save; 3944 #cf::emergency_save;
3802 cf::write_runtime_sync; # external watchdog should not bark
3803 3945
3804 warn "syncing database to disk";
3805 BDB::db_env_txn_checkpoint $DB_ENV;
3806
3807 # if anything goes wrong in here, we should simply crash as we already saved
3808
3809 warn "flushing outstanding aio requests";
3810 while (IO::AIO::nreqs || BDB::nreqs) {
3811 Coro::EV::timer_once 0.01; # let the sync_job do it's thing
3812 }
3813
3814 warn "cancelling all extension coros"; 3946 trace "perl_reload: cancelling all extension coros";
3815 $_->cancel for values %EXT_CORO; 3947 $_->cancel for values %EXT_CORO;
3816 %EXT_CORO = (); 3948 %EXT_CORO = ();
3817 3949
3818 warn "removing commands"; 3950 trace "perl_reload: removing commands";
3819 %COMMAND = (); 3951 %COMMAND = ();
3820 3952
3821 warn "removing ext/exti commands"; 3953 trace "perl_reload: removing ext/exti commands";
3822 %EXTCMD = (); 3954 %EXTCMD = ();
3823 %EXTICMD = (); 3955 %EXTICMD = ();
3824 3956
3825 warn "unloading/nuking all extensions"; 3957 trace "perl_reload: unloading/nuking all extensions";
3826 for my $pkg (@EXTS) { 3958 for my $pkg (@EXTS) {
3827 warn "... unloading $pkg"; 3959 trace "... unloading $pkg";
3828 3960
3829 if (my $cb = $pkg->can ("unload")) { 3961 if (my $cb = $pkg->can ("unload")) {
3830 eval { 3962 eval {
3831 $cb->($pkg); 3963 $cb->($pkg);
3832 1 3964 1
3833 } or warn "$pkg unloaded, but with errors: $@"; 3965 } or error "$pkg unloaded, but with errors: $@";
3834 } 3966 }
3835 3967
3836 warn "... clearing $pkg"; 3968 trace "... clearing $pkg";
3837 clear_package $pkg; 3969 clear_package $pkg;
3838 } 3970 }
3839 3971
3840 warn "unloading all perl modules loaded from $LIBDIR"; 3972 trace "perl_reload: unloading all perl modules loaded from $LIBDIR";
3841 while (my ($k, $v) = each %INC) { 3973 while (my ($k, $v) = each %INC) {
3842 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 3974 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
3843 3975
3844 warn "... unloading $k"; 3976 trace "... unloading $k";
3845 delete $INC{$k}; 3977 delete $INC{$k};
3846 3978
3847 $k =~ s/\.pm$//; 3979 $k =~ s/\.pm$//;
3848 $k =~ s/\//::/g; 3980 $k =~ s/\//::/g;
3849 3981
… …
3852 } 3984 }
3853 3985
3854 clear_package $k; 3986 clear_package $k;
3855 } 3987 }
3856 3988
3857 warn "getting rid of safe::, as good as possible"; 3989 trace "perl_reload: getting rid of safe::, as good as possible";
3858 clear_package "safe::$_" 3990 clear_package "safe::$_"
3859 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 3991 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3860 3992
3861 warn "unloading cf.pm \"a bit\""; 3993 trace "perl_reload: unloading cf.pm \"a bit\"";
3862 delete $INC{"cf.pm"}; 3994 delete $INC{"cf.pm"};
3863 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES; 3995 delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3864 3996
3865 # don't, removes xs symbols, too, 3997 # don't, removes xs symbols, too,
3866 # and global variables created in xs 3998 # and global variables created in xs
3867 #clear_package __PACKAGE__; 3999 #clear_package __PACKAGE__;
3868 4000
3869 warn "unload completed, starting to reload now"; 4001 info "perl_reload: unload completed, starting to reload now";
3870 4002
3871 warn "reloading cf.pm"; 4003 trace "perl_reload: reloading cf.pm";
3872 require cf; 4004 require cf;
3873 cf::_connect_to_perl_1; 4005 cf::_connect_to_perl_1;
3874 4006
3875 warn "loading config and database again"; 4007 trace "perl_reload: loading config and database again";
3876 cf::reload_config; 4008 cf::reload_config;
3877 4009
3878 warn "loading extensions"; 4010 trace "perl_reload: loading extensions";
3879 cf::load_extensions; 4011 cf::load_extensions;
3880 4012
3881 if ($REATTACH_ON_RELOAD) { 4013 if ($REATTACH_ON_RELOAD) {
3882 warn "reattaching attachments to objects/players"; 4014 trace "perl_reload: reattaching attachments to objects/players";
3883 _global_reattach; # objects, sockets 4015 _global_reattach; # objects, sockets
3884 warn "reattaching attachments to maps"; 4016 trace "perl_reload: reattaching attachments to maps";
3885 reattach $_ for values %MAP; 4017 reattach $_ for values %MAP;
3886 warn "reattaching attachments to players"; 4018 trace "perl_reload: reattaching attachments to players";
3887 reattach $_ for values %PLAYER; 4019 reattach $_ for values %PLAYER;
3888 } 4020 }
3889 4021
3890 warn "running post_init jobs"; 4022 cf::_post_init 1;
3891 (pop @POST_INIT)->(1) while @POST_INIT;
3892 4023
3893 warn "leaving sync_job"; 4024 trace "perl_reload: leaving sync_job";
3894 4025
3895 1 4026 1
3896 } or do { 4027 } or do {
3897 warn $@; 4028 error $@;
3898 cf::cleanup "error while reloading, exiting."; 4029 cf::cleanup "perl_reload: error, exiting.";
3899 }; 4030 };
3900 4031
3901 warn "reloaded";
3902 --$RELOAD; 4032 --$RELOAD;
3903 } 4033 }
3904 4034
3905 $t1 = AE::time - $t1; 4035 $t1 = AE::time - $t1;
3906 warn "reload completed in ${t1}s\n"; 4036 info "perl_reload: completed in ${t1}s\n";
3907}; 4037};
3908 4038
3909our $RELOAD_WATCHER; # used only during reload 4039our $RELOAD_WATCHER; # used only during reload
3910 4040
3911sub reload_perl() { 4041sub reload_perl() {
… …
3932 reload_perl; 4062 reload_perl;
3933 }; 4063 };
3934 } 4064 }
3935}; 4065};
3936 4066
3937unshift @INC, $LIBDIR; 4067#############################################################################
3938 4068
3939my $bug_warning = 0; 4069my $bug_warning = 0;
3940 4070
3941our @WAIT_FOR_TICK; 4071our @WAIT_FOR_TICK;
3942our @WAIT_FOR_TICK_BEGIN; 4072our @WAIT_FOR_TICK_BEGIN;
3943 4073
3944sub wait_for_tick { 4074sub wait_for_tick() {
3945 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4075 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3946 4076
3947 my $signal = new Coro::Signal; 4077 my $signal = new Coro::Signal;
3948 push @WAIT_FOR_TICK, $signal; 4078 push @WAIT_FOR_TICK, $signal;
3949 $signal->wait; 4079 $signal->wait;
3950} 4080}
3951 4081
3952sub wait_for_tick_begin { 4082sub wait_for_tick_begin() {
3953 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main; 4083 return Coro::cede if tick_inhibit || $Coro::current == $Coro::main;
3954 4084
3955 my $signal = new Coro::Signal; 4085 my $signal = new Coro::Signal;
3956 push @WAIT_FOR_TICK_BEGIN, $signal; 4086 push @WAIT_FOR_TICK_BEGIN, $signal;
3957 $signal->wait; 4087 $signal->wait;
… …
3971 if ($NOW >= $NEXT_RUNTIME_WRITE) { 4101 if ($NOW >= $NEXT_RUNTIME_WRITE) {
3972 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.; 4102 $NEXT_RUNTIME_WRITE = List::Util::max $NEXT_RUNTIME_WRITE + 10, $NOW + 5.;
3973 Coro::async_pool { 4103 Coro::async_pool {
3974 $Coro::current->{desc} = "runtime saver"; 4104 $Coro::current->{desc} = "runtime saver";
3975 write_runtime_sync 4105 write_runtime_sync
3976 or warn "ERROR: unable to write runtime file: $!"; 4106 or error "ERROR: unable to write runtime file: $!";
3977 }; 4107 };
3978 } 4108 }
3979 4109
3980 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) { 4110 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
3981 $sig->send; 4111 $sig->send;
… …
3989 4119
3990 if (0) { 4120 if (0) {
3991 if ($NEXT_TICK) { 4121 if ($NEXT_TICK) {
3992 my $jitter = $TICK_START - $NEXT_TICK; 4122 my $jitter = $TICK_START - $NEXT_TICK;
3993 $JITTER = $JITTER * 0.75 + $jitter * 0.25; 4123 $JITTER = $JITTER * 0.75 + $jitter * 0.25;
3994 warn "jitter $JITTER\n";#d# 4124 debug "jitter $JITTER\n";#d#
3995 } 4125 }
3996 } 4126 }
3997} 4127}
3998 4128
3999{ 4129{
… …
4044 IO::AIO::min_parallel 8; 4174 IO::AIO::min_parallel 8;
4045 IO::AIO::max_poll_time $TICK * 0.1; 4175 IO::AIO::max_poll_time $TICK * 0.1;
4046 undef $AnyEvent::AIO::WATCHER; 4176 undef $AnyEvent::AIO::WATCHER;
4047} 4177}
4048 4178
4049my $_log_backtrace; 4179our $_log_backtrace;
4180our $_log_backtrace_last;
4050 4181
4051sub _log_backtrace { 4182sub _log_backtrace {
4052 my ($msg, @addr) = @_; 4183 my ($msg, @addr) = @_;
4053 4184
4054 $msg =~ s/\n//; 4185 $msg =~ s/\n$//;
4055 4186
4187 if ($_log_backtrace_last eq $msg) {
4188 LOG llevInfo, "[ABT] $msg\n";
4189 LOG llevInfo, "[ABT] [duplicate, suppressed]\n";
4056 # limit the # of concurrent backtraces 4190 # limit the # of concurrent backtraces
4057 if ($_log_backtrace < 2) { 4191 } elsif ($_log_backtrace < 2) {
4192 $_log_backtrace_last = $msg;
4058 ++$_log_backtrace; 4193 ++$_log_backtrace;
4059 my $perl_bt = Carp::longmess $msg; 4194 my $perl_bt = Carp::longmess $msg;
4060 async { 4195 async {
4061 $Coro::current->{desc} = "abt $msg"; 4196 $Coro::current->{desc} = "abt $msg";
4062 4197
… …
4082 LOG llevInfo, "[ABT] $_\n" for @bt; 4217 LOG llevInfo, "[ABT] $_\n" for @bt;
4083 --$_log_backtrace; 4218 --$_log_backtrace;
4084 }; 4219 };
4085 } else { 4220 } else {
4086 LOG llevInfo, "[ABT] $msg\n"; 4221 LOG llevInfo, "[ABT] $msg\n";
4087 LOG llevInfo, "[ABT] [suppressed]\n"; 4222 LOG llevInfo, "[ABT] [overload, suppressed]\n";
4088 } 4223 }
4089} 4224}
4090 4225
4091# load additional modules 4226# load additional modules
4092require "cf/$_.pm" for @EXTRA_MODULES; 4227require "cf/$_.pm" for @EXTRA_MODULES;

Diff Legend

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