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.210 by root, Mon Feb 12 01:32:49 2007 UTC vs.
Revision 1.267 by root, Sat May 19 00:08:11 2007 UTC

… …
3use utf8; 3use utf8;
4use strict; 4use strict;
5 5
6use Symbol; 6use Symbol;
7use List::Util; 7use List::Util;
8use Socket;
8use Storable; 9use Storable;
10use Event;
9use Opcode; 11use Opcode;
10use Safe; 12use Safe;
11use Safe::Hole; 13use Safe::Hole;
12 14
13use Coro 3.5 (); 15use Coro 3.61 ();
16use Coro::State;
17use Coro::Handle;
14use Coro::Event; 18use Coro::Event;
15use Coro::Timer; 19use Coro::Timer;
16use Coro::Signal; 20use Coro::Signal;
17use Coro::Semaphore; 21use Coro::Semaphore;
18use Coro::AIO; 22use Coro::AIO;
23use Coro::Storable;
19 24
20use BDB (); 25use BDB ();
21use Data::Dumper; 26use Data::Dumper;
22use Digest::MD5; 27use Digest::MD5;
23use Fcntl; 28use Fcntl;
29use YAML::Syck ();
24use IO::AIO 2.32 (); 30use IO::AIO 2.32 ();
25use YAML::Syck ();
26use Time::HiRes; 31use Time::HiRes;
27use Compress::LZF; 32use Compress::LZF;
28 33
34# configure various modules to our taste
35#
36$Storable::canonical = 1; # reduce rsync transfers
37Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
29Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later 38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
30 39
31use Event; $Event::Eval = 1; # no idea why this is required, but it is 40$Event::Eval = 1; # no idea why this is required, but it is
32
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 41
35# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 42# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
36$YAML::Syck::ImplicitUnicode = 1; 43$YAML::Syck::ImplicitUnicode = 1;
37 44
38$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority 45$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
46
47sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
39 48
40our %COMMAND = (); 49our %COMMAND = ();
41our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
42 51
43our @EXTS = (); # list of extension package names 52our @EXTS = (); # list of extension package names
44our %EXTCMD = (); 53our %EXTCMD = ();
45our %EXT_CORO = (); # coroutines bound to extensions 54our %EXT_CORO = (); # coroutines bound to extensions
46our %EXT_MAP = (); # pluggable maps 55our %EXT_MAP = (); # pluggable maps
47 56
57our $RELOAD; # number of reloads so far
48our @EVENT; 58our @EVENT;
49our $LIBDIR = datadir . "/ext";
50 59
51our $TICK = MAX_TIME * 1e-6; 60our $CONFDIR = confdir;
61our $DATADIR = datadir;
62our $LIBDIR = "$DATADIR/ext";
63our $PODDIR = "$DATADIR/pod";
64our $MAPDIR = "$DATADIR/" . mapdir;
65our $LOCALDIR = localdir;
66our $TMPDIR = "$LOCALDIR/" . tmpdir;
67our $UNIQUEDIR = "$LOCALDIR/" . uniquedir;
68our $PLAYERDIR = "$LOCALDIR/" . playerdir;
69our $RANDOMDIR = "$LOCALDIR/random";
70our $BDBDIR = "$LOCALDIR/db";
71
72our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
52our $TICK_WATCHER; 73our $TICK_WATCHER;
53our $AIO_POLL_WATCHER; 74our $AIO_POLL_WATCHER;
54our $WRITE_RUNTIME_WATCHER; 75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
55our $NEXT_TICK; 76our $NEXT_TICK;
56our $NOW; 77our $NOW;
57our $USE_FSYNC = 1; # use fsync to write maps - default off 78our $USE_FSYNC = 1; # use fsync to write maps - default off
58 79
59our $BDB_POLL_WATCHER; 80our $BDB_POLL_WATCHER;
… …
65our $RUNTIME; 86our $RUNTIME;
66 87
67our %PLAYER; # all users 88our %PLAYER; # all users
68our %MAP; # all maps 89our %MAP; # all maps
69our $LINK_MAP; # the special {link} map, which is always available 90our $LINK_MAP; # the special {link} map, which is always available
70our $RANDOM_MAPS = cf::localdir . "/random";
71our $BDB_ENV_DIR = cf::localdir . "/db";
72
73our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
74our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
75 91
76# used to convert map paths into valid unix filenames by replacing / by ∕ 92# used to convert map paths into valid unix filenames by replacing / by ∕
77our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
78 94
95our $LOAD; # a number between 0 (idle) and 1 (too many objects)
96our $LOADAVG; # same thing, but with alpha-smoothing
97our $tick_start; # for load detecting purposes
98
79binmode STDOUT; 99binmode STDOUT;
80binmode STDERR; 100binmode STDERR;
81 101
82# read virtual server time, if available 102# read virtual server time, if available
83unless ($RUNTIME || !-e cf::localdir . "/runtime") { 103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
84 open my $fh, "<", cf::localdir . "/runtime" 104 open my $fh, "<", "$LOCALDIR/runtime"
85 or die "unable to read runtime file: $!"; 105 or die "unable to read runtime file: $!";
86 $RUNTIME = <$fh> + 0.; 106 $RUNTIME = <$fh> + 0.;
87} 107}
88 108
89mkdir cf::localdir; 109mkdir $_
90mkdir cf::localdir . "/" . cf::playerdir; 110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
91mkdir cf::localdir . "/" . cf::tmpdir;
92mkdir cf::localdir . "/" . cf::uniquedir;
93mkdir $RANDOM_MAPS;
94mkdir $BDB_ENV_DIR;
95 111
96our $EMERGENCY_POSITION; 112our $EMERGENCY_POSITION;
97 113
98sub cf::map::normalise; 114sub cf::map::normalise;
99 115
… …
110=item $cf::RUNTIME 126=item $cf::RUNTIME
111 127
112The time this server has run, starts at 0 and is increased by $cf::TICK on 128The time this server has run, starts at 0 and is increased by $cf::TICK on
113every server tick. 129every server tick.
114 130
115=item $cf::LIBDIR 131=item $cf::CONFDIR $cf::DATADIR $cf::LIBDIR $cf::PODDIR
132$cf::MAPDIR $cf::LOCALDIR $cf::TMPDIR $cf::UNIQUEDIR
133$cf::PLAYERDIR $cf::RANDOMDIR $cf::BDBDIR
116 134
117The perl library directory, where extensions and cf-specific modules can 135Various directories - "/etc", read-only install directory, perl-library
118be found. It will be added to C<@INC> automatically. 136directory, pod-directory, read-only maps directory, "/var", "/var/tmp",
137unique-items directory, player file directory, random maps directory and
138database environment.
119 139
120=item $cf::NOW 140=item $cf::NOW
121 141
122The time of the last (current) server tick. 142The time of the last (current) server tick.
123 143
124=item $cf::TICK 144=item $cf::TICK
125 145
126The interval between server ticks, in seconds. 146The interval between server ticks, in seconds.
147
148=item $cf::LOADAVG
149
150The current CPU load on the server (alpha-smoothed), as a value between 0
151(none) and 1 (overloaded), indicating how much time is spent on processing
152objects per tick. Healthy values are < 0.5.
153
154=item $cf::LOAD
155
156The raw value load value from the last tick.
127 157
128=item %cf::CFG 158=item %cf::CFG
129 159
130Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
131from wherever your confdir points to. 161from wherever your confdir points to.
132 162
133=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 163=item cf::wait_for_tick, cf::wait_for_tick_begin
134 164
135These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK) 165These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
136or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick 166returns directly I<after> the tick processing (and consequently, can only wake one process
137processing has been done. Call C<< ->wait >> on them to maximise the 167per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
138window of cpu time available, or simply to synchronise to the server tick.
139 168
140=back 169=back
141 170
142=cut 171=cut
143 172
144BEGIN { 173BEGIN {
145 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
146 my $msg = join "", @_; 175 my $msg = join "", @_;
147 utf8::encode $msg;
148 176
149 $msg .= "\n" 177 $msg .= "\n"
150 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
151 179
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
152 LOG llevError, $msg; 183 LOG llevError, $msg;
153 }; 184 };
154} 185}
155 186
156@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
… …
202 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge; 233 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
203 $d 234 $d
204 } || "[unable to dump $_[0]: '$@']"; 235 } || "[unable to dump $_[0]: '$@']";
205} 236}
206 237
207use JSON::Syck (); # TODO# replace by JSON::PC once working 238use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
208 239
209=item $ref = cf::from_json $json 240=item $ref = cf::from_json $json
210 241
211Converts a JSON string into the corresponding perl data structure. 242Converts a JSON string into the corresponding perl data structure.
212 243
213=cut
214
215sub from_json($) {
216 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
217 JSON::Syck::Load $_[0]
218}
219
220=item $json = cf::to_json $ref 244=item $json = cf::to_json $ref
221 245
222Converts a perl data structure into its JSON representation. 246Converts a perl data structure into its JSON representation.
223
224=cut
225
226sub to_json($) {
227 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
228 JSON::Syck::Dump $_[0]
229}
230 247
231=item cf::lock_wait $string 248=item cf::lock_wait $string
232 249
233Wait until the given lock is available. See cf::lock_acquire. 250Wait until the given lock is available. See cf::lock_acquire.
234 251
… …
240returned. 257returned.
241 258
242Lock names should begin with a unique identifier (for example, cf::map::find 259Lock names should begin with a unique identifier (for example, cf::map::find
243uses map_find and cf::map::load uses map_load). 260uses map_find and cf::map::load uses map_load).
244 261
262=item $locked = cf::lock_active $string
263
264Return true if the lock is currently active, i.e. somebody has locked it.
265
245=cut 266=cut
246 267
247our %LOCK; 268our %LOCK;
248 269
249sub lock_wait($) { 270sub lock_wait($) {
… …
268 # wake up all waiters, to be on the safe side 289 # wake up all waiters, to be on the safe side
269 $_->ready for @{ delete $LOCK{$key} }; 290 $_->ready for @{ delete $LOCK{$key} };
270 } 291 }
271} 292}
272 293
294sub lock_active($) {
295 my ($key) = @_;
296
297 ! ! $LOCK{$key}
298}
299
273sub freeze_mainloop { 300sub freeze_mainloop {
274 return unless $TICK_WATCHER->is_active; 301 return unless $TICK_WATCHER->is_active;
275 302
276 my $guard = Coro::guard { 303 my $guard = Coro::guard {
277 $TICK_WATCHER->start; 304 $TICK_WATCHER->start;
278 $WRITE_RUNTIME_WATCHER->start;
279 }; 305 };
280 $WRITE_RUNTIME_WATCHER->stop;
281 $TICK_WATCHER->stop; 306 $TICK_WATCHER->stop;
282 $guard 307 $guard
283} 308}
284 309
285=item cf::async { BLOCK } 310=item cf::async { BLOCK }
… …
307 332
308sub sync_job(&) { 333sub sync_job(&) {
309 my ($job) = @_; 334 my ($job) = @_;
310 335
311 if ($Coro::current == $Coro::main) { 336 if ($Coro::current == $Coro::main) {
337 my $time = Event::time;
338
312 # this is the main coro, too bad, we have to block 339 # this is the main coro, too bad, we have to block
313 # till the operation succeeds, freezing the server :/ 340 # till the operation succeeds, freezing the server :/
314 341
315 # TODO: use suspend/resume instead 342 # TODO: use suspend/resume instead
316 # (but this is cancel-safe) 343 # (but this is cancel-safe)
… …
327 354
328 while ($busy) { 355 while ($busy) {
329 Coro::cede or Event::one_event; 356 Coro::cede or Event::one_event;
330 } 357 }
331 358
359 $time = Event::time - $time;
360
361 LOG llevError | logBacktrace, Carp::longmess "long sync job"
362 if $time > $TICK * 0.5 && $TICK_WATCHER->is_active;
363
364 $tick_start += $time; # do not account sync jobs to server load
365
332 wantarray ? @res : $res[0] 366 wantarray ? @res : $res[0]
333 } else { 367 } else {
334 # we are in another coroutine, how wonderful, everything just works 368 # we are in another coroutine, how wonderful, everything just works
335 369
336 $job->() 370 $job->()
… …
356 390
357 $coro 391 $coro
358} 392}
359 393
360sub write_runtime { 394sub write_runtime {
361 my $runtime = cf::localdir . "/runtime"; 395 my $runtime = "$LOCALDIR/runtime";
396
397 # first touch the runtime file to show we are still running:
398 # the fsync below can take a very very long time.
399
400 if (my $fh = aio_open $runtime, O_WRONLY, 0) {
401 utime undef, undef, $fh;
402 }
403
404 my $guard = cf::lock_acquire "write_runtime";
362 405
363 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 406 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
364 or return; 407 or return;
365 408
366 my $value = $cf::RUNTIME + 90 + 10; 409 my $value = $cf::RUNTIME + 90 + 10;
… …
372 415
373 # always fsync - this file is important 416 # always fsync - this file is important
374 aio_fsync $fh 417 aio_fsync $fh
375 and return; 418 and return;
376 419
420 # touch it again to show we are up-to-date
421 utime undef, undef, $fh;
422
377 close $fh 423 close $fh
378 or return; 424 or return;
379 425
380 aio_rename "$runtime~", $runtime 426 aio_rename "$runtime~", $runtime
381 and return; 427 and return;
382 428
429 warn "runtime file written.\n";#d#
430
383 1 431 1
432}
433
434=item cf::datalog type => key => value, ...
435
436Log a datalog packet of the given type with the given key-value pairs.
437
438=cut
439
440sub datalog($@) {
441 my ($type, %kv) = @_;
442 warn "DATALOG ", JSON::XS->new->ascii->encode ({ %kv, type => $type });
384} 443}
385 444
386=back 445=back
387 446
388=cut 447=cut
… …
568 $registry = $CB_TYPE[$object_type] ||= []; 627 $registry = $CB_TYPE[$object_type] ||= [];
569 628
570 } elsif ($type eq "subtype") { 629 } elsif ($type eq "subtype") {
571 defined $object_type or Carp::croak "subtype specified without type"; 630 defined $object_type or Carp::croak "subtype specified without type";
572 my $object_subtype = shift @arg; 631 my $object_subtype = shift @arg;
573 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 632 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
574 633
575 } elsif ($type eq "package") { 634 } elsif ($type eq "package") {
576 my $pkg = shift @arg; 635 my $pkg = shift @arg;
577 636
578 while (my ($name, $id) = each %cb_id) { 637 while (my ($name, $id) = each %cb_id) {
… …
619 if (ref $_[0]) { 678 if (ref $_[0]) {
620 _object_attach @_; 679 _object_attach @_;
621 } else { 680 } else {
622 _attach shift->_attach_registry, @_; 681 _attach shift->_attach_registry, @_;
623 } 682 }
683 _recalc_want;
624}; 684};
625 685
626# all those should be optimised 686# all those should be optimised
627sub cf::attachable::detach { 687sub cf::attachable::detach {
628 my ($obj, $name) = @_; 688 my ($obj, $name) = @_;
… …
631 delete $obj->{_attachment}{$name}; 691 delete $obj->{_attachment}{$name};
632 reattach ($obj); 692 reattach ($obj);
633 } else { 693 } else {
634 Carp::croak "cannot, currently, detach class attachments"; 694 Carp::croak "cannot, currently, detach class attachments";
635 } 695 }
696 _recalc_want;
636}; 697};
637 698
638sub cf::attachable::attached { 699sub cf::attachable::attached {
639 my ($obj, $name) = @_; 700 my ($obj, $name) = @_;
640 701
… …
787 } 848 }
788 } else { 849 } else {
789 aio_unlink $filename; 850 aio_unlink $filename;
790 aio_unlink "$filename.pst"; 851 aio_unlink "$filename.pst";
791 } 852 }
792
793 #d##TODO# nuke non .map-files if exist
794 if ($filename =~ s/\.map$//) {
795 aio_unlink $filename;
796 aio_unlink "$filename.pst";
797 }
798 } 853 }
799} 854}
800 855
801sub object_freezer_as_string { 856sub object_freezer_as_string {
802 my ($rdata, $objs) = @_; 857 my ($rdata, $objs) = @_;
… …
808 863
809sub object_thawer_load { 864sub object_thawer_load {
810 my ($filename) = @_; 865 my ($filename) = @_;
811 866
812 my ($data, $av); 867 my ($data, $av);
813
814 #d#TODO remove .map if file does not exist
815 aio_stat $filename and $filename =~ s/\.map$//;
816 868
817 (aio_load $filename, $data) >= 0 869 (aio_load $filename, $data) >= 0
818 or return; 870 or return;
819 871
820 unless (aio_stat "$filename.pst") { 872 unless (aio_stat "$filename.pst") {
… …
959Returns the given player object, loading it if necessary (might block). 1011Returns the given player object, loading it if necessary (might block).
960 1012
961=cut 1013=cut
962 1014
963sub playerdir($) { 1015sub playerdir($) {
964 cf::localdir 1016 "$PLAYERDIR/"
965 . "/"
966 . cf::playerdir
967 . "/"
968 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1017 . (ref $_[0] ? $_[0]->ob->name : $_[0])
969} 1018}
970 1019
971sub path($) { 1020sub path($) {
972 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1021 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
973 1022
974 (playerdir $login) . "/$login.pl" 1023 (playerdir $login) . "/playerdata"
975} 1024}
976 1025
977sub find_active($) { 1026sub find_active($) {
978 $cf::PLAYER{$_[0]} 1027 $cf::PLAYER{$_[0]}
979 and $cf::PLAYER{$_[0]}->active 1028 and $cf::PLAYER{$_[0]}->active
… …
992 my $login = $_[0]; 1041 my $login = $_[0];
993 1042
994 my $guard = cf::lock_acquire "user_find:$login"; 1043 my $guard = cf::lock_acquire "user_find:$login";
995 1044
996 $cf::PLAYER{$_[0]} || do { 1045 $cf::PLAYER{$_[0]} || do {
1046 # rename old playerfiles to new ones
1047 #TODO: remove when no longer required
1048 aio_link +(playerdir $login) . "/$login.pl.pst", (playerdir $login) . "/playerdata.pst";
1049 aio_link +(playerdir $login) . "/$login.pl" , (playerdir $login) . "/playerdata";
1050 aio_unlink +(playerdir $login) . "/$login.pl.pst";
1051 aio_unlink +(playerdir $login) . "/$login.pl";
1052
997 my $pl = load_pl path $login 1053 my $pl = load_pl path $login
998 or return; 1054 or return;
999 $cf::PLAYER{$login} = $pl 1055 $cf::PLAYER{$login} = $pl
1000 } 1056 }
1001 } 1057 }
… …
1038 1094
1039=cut 1095=cut
1040 1096
1041sub quit_character { 1097sub quit_character {
1042 my ($pl) = @_; 1098 my ($pl) = @_;
1099
1100 my $name = $pl->ob->name;
1043 1101
1044 $pl->{deny_save} = 1; 1102 $pl->{deny_save} = 1;
1045 $pl->password ("*"); # this should lock out the player until we nuked the dir 1103 $pl->password ("*"); # this should lock out the player until we nuked the dir
1046 1104
1047 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1105 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1052 my $path = playerdir $pl; 1110 my $path = playerdir $pl;
1053 my $temp = "$path~$cf::RUNTIME~deleting~"; 1111 my $temp = "$path~$cf::RUNTIME~deleting~";
1054 aio_rename $path, $temp; 1112 aio_rename $path, $temp;
1055 delete $cf::PLAYER{$pl->ob->name}; 1113 delete $cf::PLAYER{$pl->ob->name};
1056 $pl->destroy; 1114 $pl->destroy;
1115
1116 my $prefix = qr<^~\Q$name\E/>;
1117
1118 # nuke player maps
1119 $cf::MAP{$_}->nuke for grep /$prefix/, keys %cf::MAP;
1120
1057 IO::AIO::aio_rmtree $temp; 1121 IO::AIO::aio_rmtree $temp;
1122}
1123
1124=item $pl->kick
1125
1126Kicks a player out of the game. This destroys the connection.
1127
1128=cut
1129
1130sub kick {
1131 my ($pl, $kicker) = @_;
1132
1133 $pl->invoke (cf::EVENT_PLAYER_KICK, $kicker);
1134 $pl->killer ("kicked");
1135 $pl->ns->destroy;
1058} 1136}
1059 1137
1060=item cf::player::list_logins 1138=item cf::player::list_logins
1061 1139
1062Returns am arrayref of all valid playernames in the system, can take a 1140Returns am arrayref of all valid playernames in the system, can take a
1063while and may block, so not sync_job-capable, ever. 1141while and may block, so not sync_job-capable, ever.
1064 1142
1065=cut 1143=cut
1066 1144
1067sub list_logins { 1145sub list_logins {
1068 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1146 my $dirs = aio_readdir $PLAYERDIR
1069 or return []; 1147 or return [];
1070 1148
1071 my @logins; 1149 my @logins;
1072 1150
1073 for my $login (@$dirs) { 1151 for my $login (@$dirs) {
… …
1108 } 1186 }
1109 1187
1110 \@paths 1188 \@paths
1111} 1189}
1112 1190
1113=item $player->ext_reply ($msgid, $msgtype, %msg) 1191=item $player->ext_reply ($msgid, %msg)
1114 1192
1115Sends an ext reply to the player. 1193Sends an ext reply to the player.
1116 1194
1117=cut 1195=cut
1118 1196
1119sub ext_reply($$$%) { 1197sub ext_reply($$%) {
1120 my ($self, $id, %msg) = @_; 1198 my ($self, $id, %msg) = @_;
1121 1199
1122 $msg{msgid} = $id; 1200 $msg{msgid} = $id;
1123 1201
1124 $self->send ("ext " . cf::to_json \%msg); 1202 $self->send ("ext " . cf::to_json \%msg);
1125} 1203}
1126 1204
1127package cf; 1205=item $player->ext_event ($type, %msg)
1206
1207Sends an ext event to the client.
1208
1209=cut
1210
1211sub ext_event($$%) {
1212 my ($self, $type, %msg) = @_;
1213
1214 $self->ns->ext_event ($type, %msg);
1215}
1216
1217=head3 cf::region
1218
1219=over 4
1220
1221=cut
1222
1223package cf::region;
1224
1225=item cf::region::find_by_path $path
1226
1227Tries to decuce the probable region for a map knowing only its path.
1228
1229=cut
1230
1231sub find_by_path($) {
1232 my ($path) = @_;
1233
1234 my ($match, $specificity);
1235
1236 for my $region (list) {
1237 if ($region->match && $path =~ $region->match) {
1238 ($match, $specificity) = ($region, $region->specificity)
1239 if $region->specificity > $specificity;
1240 }
1241 }
1242
1243 $match
1244}
1128 1245
1129=back 1246=back
1130
1131 1247
1132=head3 cf::map 1248=head3 cf::map
1133 1249
1134=over 4 1250=over 4
1135 1251
… …
1273 1389
1274# the original (read-only) location 1390# the original (read-only) location
1275sub load_path { 1391sub load_path {
1276 my ($self) = @_; 1392 my ($self) = @_;
1277 1393
1278 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1394 "$MAPDIR/$self->{path}.map"
1279} 1395}
1280 1396
1281# the temporary/swap location 1397# the temporary/swap location
1282sub save_path { 1398sub save_path {
1283 my ($self) = @_; 1399 my ($self) = @_;
1284 1400
1285 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1401 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1286 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1402 "$TMPDIR/$path.map"
1287} 1403}
1288 1404
1289# the unique path, undef == no special unique path 1405# the unique path, undef == no special unique path
1290sub uniq_path { 1406sub uniq_path {
1291 my ($self) = @_; 1407 my ($self) = @_;
1292 1408
1293 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1409 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1294 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1410 "$UNIQUEDIR/$path"
1295} 1411}
1296 1412
1297# and all this just because we cannot iterate over 1413# and all this just because we cannot iterate over
1298# all maps in C++... 1414# all maps in C++...
1299sub change_all_map_light { 1415sub change_all_map_light {
… …
1307 my ($self) = @_; 1423 my ($self) = @_;
1308 1424
1309 utf8::encode (my $save = $self->save_path); 1425 utf8::encode (my $save = $self->save_path);
1310 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save; 1426 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;
1311 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst"; 1427 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";
1312
1313 #d#TODO remove .map and also nuke
1314 $save =~ s/\.map// or return;#d#
1315 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink $save;#d#
1316 IO::AIO::aioreq_pri 4; Coro::AIO::aio_unlink "$save.pst";#d#
1317} 1428}
1318 1429
1319sub load_header_from($) { 1430sub load_header_from($) {
1320 my ($self, $path) = @_; 1431 my ($self, $path) = @_;
1321 1432
… …
1371 $self->load_header_orig 1482 $self->load_header_orig
1372 or return; 1483 or return;
1373 $self->prepare_orig; 1484 $self->prepare_orig;
1374 } 1485 }
1375 1486
1487 $self->default_region (cf::region::find_by_path $self->{path})
1488 unless $self->default_region;
1489
1376 1 1490 1
1377} 1491}
1378 1492
1379sub find; 1493sub find;
1380sub find { 1494sub find {
… …
1413 my ($self) = @_; 1527 my ($self) = @_;
1414 1528
1415 local $self->{deny_reset} = 1; # loading can take a long time 1529 local $self->{deny_reset} = 1; # loading can take a long time
1416 1530
1417 my $path = $self->{path}; 1531 my $path = $self->{path};
1532
1533 {
1418 my $guard = cf::lock_acquire "map_load:$path"; 1534 my $guard = cf::lock_acquire "map_load:$path";
1419 1535
1420 return if $self->in_memory != cf::MAP_SWAPPED; 1536 return if $self->in_memory != cf::MAP_SWAPPED;
1421 1537
1422 $self->in_memory (cf::MAP_LOADING); 1538 $self->in_memory (cf::MAP_LOADING);
1423 1539
1424 $self->alloc; 1540 $self->alloc;
1425 1541
1426 $self->pre_load; 1542 $self->pre_load;
1427
1428 $self->_load_objects ($self->{load_path}, 1)
1429 or return;
1430
1431 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1432 if delete $self->{load_original};
1433
1434 if (my $uniq = $self->uniq_path) {
1435 utf8::encode $uniq;
1436 if (aio_open $uniq, O_RDONLY, 0) {
1437 $self->clear_unique_items;
1438 $self->_load_objects ($uniq, 0);
1439 }
1440 }
1441
1442 Coro::cede;
1443
1444 # now do the right thing for maps
1445 $self->link_multipart_objects;
1446
1447 unless ($self->{deny_activate}) {
1448 $self->decay_objects;
1449 $self->fix_auto_apply;
1450 $self->update_buttons;
1451 Coro::cede; 1543 Coro::cede;
1452 $self->set_darkness_map; 1544
1545 $self->_load_objects ($self->{load_path}, 1)
1546 or return;
1547
1548 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1549 if delete $self->{load_original};
1550
1551 if (my $uniq = $self->uniq_path) {
1552 utf8::encode $uniq;
1553 if (aio_open $uniq, O_RDONLY, 0) {
1554 $self->clear_unique_items;
1555 $self->_load_objects ($uniq, 0);
1556 }
1557 }
1558
1559 Coro::cede;
1560 # now do the right thing for maps
1561 $self->link_multipart_objects;
1453 $self->difficulty ($self->estimate_difficulty) 1562 $self->difficulty ($self->estimate_difficulty)
1454 unless $self->difficulty; 1563 unless $self->difficulty;
1455 Coro::cede; 1564 Coro::cede;
1565
1566 unless ($self->{deny_activate}) {
1567 $self->decay_objects;
1568 $self->fix_auto_apply;
1569 $self->update_buttons;
1570 Coro::cede;
1571 $self->set_darkness_map;
1572 Coro::cede;
1456 $self->activate; 1573 $self->activate;
1574 }
1575
1576 $self->in_memory (cf::MAP_IN_MEMORY);
1457 } 1577 }
1458 1578
1459 $self->post_load; 1579 $self->post_load;
1460
1461 $self->in_memory (cf::MAP_IN_MEMORY);
1462} 1580}
1463 1581
1464sub customise_for { 1582sub customise_for {
1465 my ($self, $ob) = @_; 1583 my ($self, $ob) = @_;
1466 1584
… …
1657instantiated unique items. May block. 1775instantiated unique items. May block.
1658 1776
1659=cut 1777=cut
1660 1778
1661sub unique_maps() { 1779sub unique_maps() {
1662 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 1780 my $files = aio_readdir $UNIQUEDIR
1663 or return; 1781 or return;
1664 1782
1665 my @paths; 1783 my @paths;
1666 1784
1667 for (@$files) { 1785 for (@$files) {
… …
1820 $map->load; 1938 $map->load;
1821 $map->load_diag; 1939 $map->load_diag;
1822 1940
1823 return unless $self->contr->active; 1941 return unless $self->contr->active;
1824 $self->activate_recursive; 1942 $self->activate_recursive;
1943
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1825 $self->enter_map ($map, $x, $y); 1945 $self->enter_map ($map, $x, $y);
1826} 1946}
1827 1947
1828cf::player->attach ( 1948cf::player->attach (
1829 on_logout => sub { 1949 on_logout => sub {
… …
1842 # try to abort aborted map switching on player login :) 1962 # try to abort aborted map switching on player login :)
1843 # should happen only on crashes 1963 # should happen only on crashes
1844 if ($pl->ob->{_link_pos}) { 1964 if ($pl->ob->{_link_pos}) {
1845 $pl->ob->enter_link; 1965 $pl->ob->enter_link;
1846 (async { 1966 (async {
1847 # we need this sleep as the login has a concurrent enter_exit running
1848 # and this sleep increases chances of the player not ending up in scorn
1849 $pl->ob->reply (undef, 1967 $pl->ob->reply (undef,
1850 "There was an internal problem at your last logout, " 1968 "There was an internal problem at your last logout, "
1851 . "the server will try to bring you to your intended destination in a second.", 1969 . "the server will try to bring you to your intended destination in a second.",
1852 cf::NDI_RED); 1970 cf::NDI_RED);
1971 # we need this sleep as the login has a concurrent enter_exit running
1972 # and this sleep increases chances of the player not ending up in scorn
1853 Coro::Timer::sleep 1; 1973 Coro::Timer::sleep 1;
1854 $pl->ob->leave_link; 1974 $pl->ob->leave_link;
1855 })->prio (2); 1975 })->prio (2);
1856 } 1976 }
1857 }, 1977 },
… …
1921 2041
1922 $rmp->{random_seed} ||= $exit->random_seed; 2042 $rmp->{random_seed} ||= $exit->random_seed;
1923 2043
1924 my $data = cf::to_json $rmp; 2044 my $data = cf::to_json $rmp;
1925 my $md5 = Digest::MD5::md5_hex $data; 2045 my $md5 = Digest::MD5::md5_hex $data;
1926 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2046 my $meta = "$RANDOMDIR/$md5.meta";
1927 2047
1928 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2048 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1929 aio_write $fh, 0, (length $data), $data, 0; 2049 aio_write $fh, 0, (length $data), $data, 0;
1930 undef $fh; 2050 undef $fh;
1931 aio_rename "$meta~", $meta; 2051 aio_rename "$meta~", $meta;
… …
1940 2060
1941 return unless $self->type == cf::PLAYER; 2061 return unless $self->type == cf::PLAYER;
1942 2062
1943 if ($exit->slaying eq "/!") { 2063 if ($exit->slaying eq "/!") {
1944 #TODO: this should de-fi-ni-te-ly not be a sync-job 2064 #TODO: this should de-fi-ni-te-ly not be a sync-job
2065 # the problem is that $exit might not survive long enough
2066 # so it needs to be done right now, right here
1945 cf::sync_job { prepare_random_map $exit }; 2067 cf::sync_job { prepare_random_map $exit };
1946 } 2068 }
1947 2069
1948 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2070 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1949 my $hp = $exit->stats->hp; 2071 my $hp = $exit->stats->hp;
… …
1957 $self->goto ($slaying, $hp, $sp); 2079 $self->goto ($slaying, $hp, $sp);
1958 2080
1959 1; 2081 1;
1960 }) { 2082 }) {
1961 $self->message ("Something went wrong deep within the crossfire server. " 2083 $self->message ("Something went wrong deep within the crossfire server. "
1962 . "I'll try to bring you back to the map you were before. " 2084 . "I'll try to bring you back to the map you were before. "
1963 . "Please report this to the dungeon master!", 2085 . "Please report this to the dungeon master!",
1964 cf::NDI_UNIQUE | cf::NDI_RED); 2086 cf::NDI_UNIQUE | cf::NDI_RED);
1965 2087
1966 warn "ERROR in enter_exit: $@"; 2088 warn "ERROR in enter_exit: $@";
1967 $self->leave_link; 2089 $self->leave_link;
1968 } 2090 }
1969 })->prio (1); 2091 })->prio (1);
… …
1982 2104
1983sub cf::client::send_drawinfo { 2105sub cf::client::send_drawinfo {
1984 my ($self, $text, $flags) = @_; 2106 my ($self, $text, $flags) = @_;
1985 2107
1986 utf8::encode $text; 2108 utf8::encode $text;
1987 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2109 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1988} 2110}
1989 2111
2112=item $client->ext_event ($type, %msg)
2113
2114Sends an exti event to the client.
2115
2116=cut
2117
2118sub cf::client::ext_event($$%) {
2119 my ($self, $type, %msg) = @_;
2120
2121 $msg{msgtype} = "event_$type";
2122 $self->send_packet ("ext " . cf::to_json \%msg);
2123}
1990 2124
1991=item $success = $client->query ($flags, "text", \&cb) 2125=item $success = $client->query ($flags, "text", \&cb)
1992 2126
1993Queues a query to the client, calling the given callback with 2127Queues a query to the client, calling the given callback with
1994the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2128the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
… …
2091 2225
2092# here we export the classes and methods available to script code 2226# here we export the classes and methods available to script code
2093 2227
2094=pod 2228=pod
2095 2229
2096The following fucntions and emthods are available within a safe environment: 2230The following functions and methods are available within a safe environment:
2097 2231
2098 cf::object contr pay_amount pay_player map 2232 cf::object contr pay_amount pay_player map
2099 cf::object::player player 2233 cf::object::player player
2100 cf::player peaceful 2234 cf::player peaceful
2101 cf::map trigger 2235 cf::map trigger
… …
2186############################################################################# 2320#############################################################################
2187 2321
2188=head2 EXTENSION DATABASE SUPPORT 2322=head2 EXTENSION DATABASE SUPPORT
2189 2323
2190Crossfire maintains a very simple database for extension use. It can 2324Crossfire maintains a very simple database for extension use. It can
2191currently store anything that can be serialised using Storable, which 2325currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2192excludes objects. 2326convert to/from binary).
2193 2327
2194The parameter C<$family> should best start with the name of the extension 2328The parameter C<$family> should best start with the name of the extension
2195using it, it should be unique. 2329using it, it should be unique.
2196 2330
2197=over 4 2331=over 4
… …
2220 BDB::CREATE | BDB::AUTO_COMMIT, 0666; 2354 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2221 cf::cleanup "db_open(db): $!" if $!; 2355 cf::cleanup "db_open(db): $!" if $!;
2222 }; 2356 };
2223 cf::cleanup "db_open(db): $@" if $@; 2357 cf::cleanup "db_open(db): $@" if $@;
2224 }; 2358 };
2225
2226 my $path = cf::localdir . "/database.pst";
2227 if (stat $path) {
2228 cf::sync_job {
2229 my $pst = Storable::retrieve $path;
2230
2231 cf::db_put (board => data => $pst->{board});
2232 cf::db_put (guildrules => data => $pst->{guildrules});
2233 cf::db_put (rent => balance => $pst->{rent}{balance});
2234 BDB::db_env_txn_checkpoint $DB_ENV;
2235
2236 unlink $path;
2237 };
2238 }
2239 } 2359 }
2240} 2360}
2241 2361
2242sub db_get($$) { 2362sub db_get($$) {
2243 my $key = "$_[0]/$_[1]"; 2363 my $key = "$_[0]/$_[1]";
2244 2364
2245 cf::sync_job { 2365 cf::sync_job {
2246 BDB::db_get $DB, undef, $key, my $data; 2366 BDB::db_get $DB, undef, $key, my $data;
2247 2367
2248 $! ? () 2368 $! ? ()
2249 : Compress::LZF::sthaw $data 2369 : $data
2250 } 2370 }
2251} 2371}
2252 2372
2253sub db_put($$$) { 2373sub db_put($$$) {
2254 BDB::dbreq_pri 4; 2374 BDB::dbreq_pri 4;
2255 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { }; 2375 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2256} 2376}
2377
2378=item cf::cache $id => [$paths...], $processversion => $process
2379
2380Generic caching function that returns the value of the resource $id,
2381caching and regenerating as required.
2382
2383This function can block.
2384
2385=cut
2386
2387sub cache {
2388 my ($id, $src, $processversion, $process) = @_;
2389
2390 my $meta =
2391 join "\x00",
2392 $processversion,
2393 map {
2394 aio_stat $_
2395 and Carp::croak "$_: $!";
2396
2397 ($_, (stat _)[7,9])
2398 } @$src;
2399
2400 my $dbmeta = db_get cache => "$id/meta";
2401 if ($dbmeta ne $meta) {
2402 # changed, we may need to process
2403
2404 my @data;
2405 my $md5;
2406
2407 for (0 .. $#$src) {
2408 0 <= aio_load $src->[$_], $data[$_]
2409 or Carp::croak "$src->[$_]: $!";
2410 }
2411
2412 # if processing is expensive, check
2413 # checksum first
2414 if (1) {
2415 $md5 =
2416 join "\x00",
2417 $processversion,
2418 map {
2419 Coro::cede;
2420 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2421 } 0.. $#$src;
2422
2423
2424 my $dbmd5 = db_get cache => "$id/md5";
2425 if ($dbmd5 eq $md5) {
2426 db_put cache => "$id/meta", $meta;
2427
2428 return db_get cache => "$id/data";
2429 }
2430 }
2431
2432 my $t1 = Time::HiRes::time;
2433 my $data = $process->(\@data);
2434 my $t2 = Time::HiRes::time;
2435
2436 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2437
2438 db_put cache => "$id/data", $data;
2439 db_put cache => "$id/md5" , $md5;
2440 db_put cache => "$id/meta", $meta;
2441
2442 return $data;
2443 }
2444
2445 db_get cache => "$id/data"
2446}
2447
2448=item fork_call { }, $args
2449
2450Executes the given code block with the given arguments in a seperate
2451process, returning the results. Everything must be serialisable with
2452Coro::Storable. May, of course, block. Note that the executed sub may
2453never block itself or use any form of Event handling.
2454
2455=cut
2456
2457sub fork_call(&@) {
2458 my ($cb, @args) = @_;
2459
2460# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2461# or die "socketpair: $!";
2462 pipe my $fh1, my $fh2
2463 or die "pipe: $!";
2464
2465 if (my $pid = fork) {
2466 close $fh2;
2467
2468 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2469 $res = Coro::Storable::thaw $res;
2470
2471 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2472
2473 die $$res unless "ARRAY" eq ref $res;
2474
2475 return wantarray ? @$res : $res->[-1];
2476 } else {
2477 reset_signals;
2478 local $SIG{__WARN__};
2479 local $SIG{__DIE__};
2480 eval {
2481 close $fh1;
2482
2483 my @res = eval { $cb->(@args) };
2484 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2485 };
2486
2487 warn $@ if $@;
2488 _exit 0;
2489 }
2490}
2491
2492
2257 2493
2258############################################################################# 2494#############################################################################
2259# the server's init and main functions 2495# the server's init and main functions
2260 2496
2261sub load_resources { 2497sub load_facedata($) {
2262 load_regions sprintf "%s/%s/regions", cf::datadir, cf::mapdir 2498 my ($path) = @_;
2499
2500 warn "loading facedata from $path\n";
2501
2502 my $facedata;
2503 0 < aio_load $path, $facedata
2504 or die "$path: $!";
2505
2506 $facedata = Coro::Storable::thaw $facedata;
2507
2508 $facedata->{version} == 2
2509 or cf::cleanup "$path: version mismatch, cannot proceed.";
2510
2511 {
2512 my $faces = $facedata->{faceinfo};
2513
2514 while (my ($face, $info) = each %$faces) {
2515 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2516 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2517 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2518 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2519 Coro::cede;
2520 }
2521
2522 while (my ($face, $info) = each %$faces) {
2523 next unless $info->{smooth};
2524 my $idx = cf::face::find $face
2525 or next;
2526 if (my $smooth = cf::face::find $info->{smooth}) {
2527 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2528 } else {
2529 warn "smooth face '$info->{smooth}' not found for face '$face'";
2530 }
2531 Coro::cede;
2532 }
2533 }
2534
2535 {
2536 my $anims = $facedata->{animinfo};
2537
2538 while (my ($anim, $info) = each %$anims) {
2539 cf::anim::set $anim, $info->{frames}, $info->{facings};
2540 Coro::cede;
2541 }
2542
2543 cf::anim::invalidate_all; # d'oh
2544 }
2545
2546 1
2547}
2548
2549sub reload_regions {
2550 load_resource_file "$MAPDIR/regions"
2263 or die "unable to load regions file\n";#d# 2551 or die "unable to load regions file\n";
2552}
2553
2554sub reload_facedata {
2555 load_facedata "$DATADIR/facedata"
2556 or die "unable to load facedata\n";
2557}
2558
2559sub reload_archetypes {
2560 load_resource_file "$DATADIR/archetypes"
2561 or die "unable to load archetypes\n";
2562}
2563
2564sub reload_treasures {
2565 load_resource_file "$DATADIR/treasures"
2566 or die "unable to load treasurelists\n";
2567}
2568
2569sub reload_resources {
2570 warn "reloading resource files...\n";
2571
2572 reload_regions;
2573 reload_facedata;
2574 reload_archetypes;
2575 reload_treasures;
2576
2577 warn "finished reloading resource files\n";
2578}
2579
2580sub init {
2581 reload_resources;
2264} 2582}
2265 2583
2266sub cfg_load { 2584sub cfg_load {
2267 open my $fh, "<:utf8", cf::confdir . "/config" 2585 open my $fh, "<:utf8", "$CONFDIR/config"
2268 or return; 2586 or return;
2269 2587
2270 local $/; 2588 local $/;
2271 *CFG = YAML::Syck::Load <$fh>; 2589 *CFG = YAML::Syck::Load <$fh>;
2272 2590
… …
2280 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 2598 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2281 and die "WARNING: m(un)lockall failed: $!\n"; 2599 and die "WARNING: m(un)lockall failed: $!\n";
2282 }; 2600 };
2283 warn $@ if $@; 2601 warn $@ if $@;
2284 } 2602 }
2285}
2286
2287sub init {
2288 load_resources;
2289} 2603}
2290 2604
2291sub main { 2605sub main {
2292 # we must not ever block the main coroutine 2606 # we must not ever block the main coroutine
2293 local $Coro::idle = sub { 2607 local $Coro::idle = sub {
… …
2354 }; 2668 };
2355 2669
2356 warn "leave emergency perl save\n"; 2670 warn "leave emergency perl save\n";
2357} 2671}
2358 2672
2673sub post_cleanup {
2674 my ($make_core) = @_;
2675
2676 warn Carp::longmess "post_cleanup backtrace"
2677 if $make_core;
2678}
2679
2359sub reload() { 2680sub do_reload_perl() {
2360 # can/must only be called in main 2681 # can/must only be called in main
2361 if ($Coro::current != $Coro::main) { 2682 if ($Coro::current != $Coro::main) {
2362 warn "can only reload from main coroutine"; 2683 warn "can only reload from main coroutine";
2363 return; 2684 return;
2364 } 2685 }
2365 2686
2366 warn "reloading..."; 2687 warn "reloading...";
2367 2688
2368 warn "cancelling server ticker"; 2689 warn "entering sync_job";
2369 $TICK_WATCHER->cancel;
2370 2690
2691 cf::sync_job {
2692 cf::write_runtime; # external watchdog should not bark
2371 cf::emergency_save; 2693 cf::emergency_save;
2694 cf::write_runtime; # external watchdog should not bark
2372 2695
2373 eval { 2696 warn "syncing database to disk";
2697 BDB::db_env_txn_checkpoint $DB_ENV;
2698
2374 # if anything goes wrong in here, we should simply crash as we already saved 2699 # if anything goes wrong in here, we should simply crash as we already saved
2375 2700
2376 warn "cancelling all WF_AUTOCANCEL watchers"; 2701 warn "cancelling all WF_AUTOCANCEL watchers";
2377 for (Event::all_watchers) { 2702 for (Event::all_watchers) {
2378 $_->cancel if $_->data & WF_AUTOCANCEL; 2703 $_->cancel if $_->data & WF_AUTOCANCEL;
2379 } 2704 }
2380
2381 warn "syncing database to disk";
2382 BDB::db_env_txn_checkpoint $DB_ENV, 0, 0, 0, sub { };
2383 2705
2384 warn "flushing outstanding aio requests"; 2706 warn "flushing outstanding aio requests";
2385 for (;;) { 2707 for (;;) {
2386 BDB::flush; 2708 BDB::flush;
2387 IO::AIO::flush; 2709 IO::AIO::flush;
2388 Coro::cede; 2710 Coro::cede;
2389 last unless IO::AIO::nreqs || BDB::nreqs; 2711 last unless IO::AIO::nreqs || BDB::nreqs;
2390 warn "iterate..."; 2712 warn "iterate...";
2391 } 2713 }
2392 2714
2715 ++$RELOAD;
2716
2393 warn "cancelling all extension coros"; 2717 warn "cancelling all extension coros";
2394 $_->cancel for values %EXT_CORO; 2718 $_->cancel for values %EXT_CORO;
2395 %EXT_CORO = (); 2719 %EXT_CORO = ();
2396 2720
2397 warn "removing commands"; 2721 warn "removing commands";
… …
2436 Symbol::delete_package "safe::$_" 2760 Symbol::delete_package "safe::$_"
2437 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2761 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2438 2762
2439 warn "unloading cf.pm \"a bit\""; 2763 warn "unloading cf.pm \"a bit\"";
2440 delete $INC{"cf.pm"}; 2764 delete $INC{"cf.pm"};
2765 delete $INC{"cf/pod.pm"};
2441 2766
2442 # don't, removes xs symbols, too, 2767 # don't, removes xs symbols, too,
2443 # and global variables created in xs 2768 # and global variables created in xs
2444 #Symbol::delete_package __PACKAGE__; 2769 #Symbol::delete_package __PACKAGE__;
2445 2770
… …
2454 2779
2455 warn "loading extensions"; 2780 warn "loading extensions";
2456 cf::load_extensions; 2781 cf::load_extensions;
2457 2782
2458 warn "reattaching attachments to objects/players"; 2783 warn "reattaching attachments to objects/players";
2459 _global_reattach; 2784 _global_reattach; # objects, sockets
2460 warn "reattaching attachments to maps"; 2785 warn "reattaching attachments to maps";
2461 reattach $_ for values %MAP; 2786 reattach $_ for values %MAP;
2787 warn "reattaching attachments to players";
2788 reattach $_ for values %PLAYER;
2462 2789
2463 warn "loading reloadable resources"; 2790 warn "leaving sync_job";
2464 load_resources;
2465 2791
2466 warn "restarting server ticker"; 2792 1
2467 2793 } or do {
2468 $TICK_WATCHER->start;
2469 };
2470
2471 if ($@) {
2472 warn $@; 2794 warn $@;
2473 warn "error while reloading, exiting."; 2795 warn "error while reloading, exiting.";
2474 exit 1; 2796 exit 1;
2475 } 2797 };
2476 2798
2477 warn "reloaded"; 2799 warn "reloaded";
2478}; 2800};
2479 2801
2480our $RELOAD_WATCHER; # used only during reload 2802our $RELOAD_WATCHER; # used only during reload
2481 2803
2804sub reload_perl() {
2805 # doing reload synchronously and two reloads happen back-to-back,
2806 # coro crashes during coro_state_free->destroy here.
2807
2808 $RELOAD_WATCHER ||= Event->timer (
2809 reentrant => 0,
2810 after => 0,
2811 data => WF_AUTOCANCEL,
2812 cb => sub {
2813 do_reload_perl;
2814 undef $RELOAD_WATCHER;
2815 },
2816 );
2817}
2818
2482register_command "reload" => sub { 2819register_command "reload" => sub {
2483 my ($who, $arg) = @_; 2820 my ($who, $arg) = @_;
2484 2821
2485 if ($who->flag (FLAG_WIZ)) { 2822 if ($who->flag (FLAG_WIZ)) {
2486 $who->message ("reloading server."); 2823 $who->message ("reloading server.");
2487 2824 async { reload_perl };
2488 # doing reload synchronously and two reloads happen back-to-back,
2489 # coro crashes during coro_state_free->destroy here.
2490
2491 $RELOAD_WATCHER ||= Event->timer (
2492 reentrant => 0,
2493 after => 0,
2494 data => WF_AUTOCANCEL,
2495 cb => sub {
2496 reload;
2497 undef $RELOAD_WATCHER;
2498 },
2499 );
2500 } 2825 }
2501}; 2826};
2502 2827
2503unshift @INC, $LIBDIR; 2828unshift @INC, $LIBDIR;
2504 2829
2505my $bug_warning = 0; 2830my $bug_warning = 0;
2831
2832our @WAIT_FOR_TICK;
2833our @WAIT_FOR_TICK_BEGIN;
2834
2835sub wait_for_tick {
2836 return unless $TICK_WATCHER->is_active;
2837 return if $Coro::current == $Coro::main;
2838
2839 my $signal = new Coro::Signal;
2840 push @WAIT_FOR_TICK, $signal;
2841 $signal->wait;
2842}
2843
2844sub wait_for_tick_begin {
2845 return unless $TICK_WATCHER->is_active;
2846 return if $Coro::current == $Coro::main;
2847
2848 my $signal = new Coro::Signal;
2849 push @WAIT_FOR_TICK_BEGIN, $signal;
2850 $signal->wait;
2851}
2506 2852
2507$TICK_WATCHER = Event->timer ( 2853$TICK_WATCHER = Event->timer (
2508 reentrant => 0, 2854 reentrant => 0,
2509 parked => 1, 2855 parked => 1,
2510 prio => 0, 2856 prio => 0,
… …
2515 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 2861 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2516 unless ++$bug_warning > 10; 2862 unless ++$bug_warning > 10;
2517 return; 2863 return;
2518 } 2864 }
2519 2865
2520 $NOW = Event::time; 2866 $NOW = $tick_start = Event::time;
2521 2867
2522 cf::server_tick; # one server iteration 2868 cf::server_tick; # one server iteration
2869
2523 $RUNTIME += $TICK; 2870 $RUNTIME += $TICK;
2524 $NEXT_TICK += $TICK; 2871 $NEXT_TICK += $TICK;
2525 2872
2526 $WAIT_FOR_TICK->broadcast; 2873 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2527 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 2874 $NEXT_RUNTIME_WRITE = $NOW + 10;
2528 2875 Coro::async_pool {
2529 Event::sweep; 2876 write_runtime
2530 Coro::cede_notself; 2877 or warn "ERROR: unable to write runtime file: $!";
2878 };
2531 2879 }
2880
2532# my $AFTER = Event::time; 2881# my $AFTER = Event::time;
2533# warn $AFTER - $NOW;#d# 2882# warn $AFTER - $NOW;#d#
2534 2883
2884 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2885 $sig->send;
2886 }
2887 while (my $sig = shift @WAIT_FOR_TICK) {
2888 $sig->send;
2889 }
2890
2891 $NOW = Event::time;
2892
2535 # if we are delayed by four ticks or more, skip them all 2893 # if we are delayed by four ticks or more, skip them all
2536 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2894 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2537 2895
2538 $TICK_WATCHER->at ($NEXT_TICK); 2896 $TICK_WATCHER->at ($NEXT_TICK);
2539 $TICK_WATCHER->start; 2897 $TICK_WATCHER->start;
2898
2899 $LOAD = ($NOW - $tick_start) / $TICK;
2900 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2901
2902 _post_tick;
2903
2904
2540 }, 2905 },
2541); 2906);
2542 2907
2543{ 2908{
2544 BDB::max_poll_time $TICK * 0.1; 2909 BDB::max_poll_time $TICK * 0.1;
… …
2572 2937
2573 cf::sync_job { 2938 cf::sync_job {
2574 eval { 2939 eval {
2575 BDB::db_env_open 2940 BDB::db_env_open
2576 $DB_ENV, 2941 $DB_ENV,
2577 $BDB_ENV_DIR, 2942 $BDBDIR,
2578 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 2943 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2579 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 2944 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2580 0666; 2945 0666;
2581 2946
2582 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 2947 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2583 2948
2584 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 2949 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2585 $DB_ENV->set_lk_detect; 2950 $DB_ENV->set_lk_detect;
2586 }; 2951 };
2587 2952
… …
2595 2960
2596 undef $Coro::AIO::WATCHER; 2961 undef $Coro::AIO::WATCHER;
2597 IO::AIO::max_poll_time $TICK * 0.1; 2962 IO::AIO::max_poll_time $TICK * 0.1;
2598 $AIO_POLL_WATCHER = Event->io ( 2963 $AIO_POLL_WATCHER = Event->io (
2599 reentrant => 0, 2964 reentrant => 0,
2965 data => WF_AUTOCANCEL,
2600 fd => IO::AIO::poll_fileno, 2966 fd => IO::AIO::poll_fileno,
2601 poll => 'r', 2967 poll => 'r',
2602 prio => 6, 2968 prio => 6,
2603 data => WF_AUTOCANCEL,
2604 cb => \&IO::AIO::poll_cb, 2969 cb => \&IO::AIO::poll_cb,
2605 ); 2970 );
2606} 2971}
2607 2972
2608$WRITE_RUNTIME_WATCHER = Event->timer ( 2973my $_log_backtrace;
2609 reentrant => 0, 2974
2610 data => WF_AUTOCANCEL, 2975sub _log_backtrace {
2611 after => 1, 2976 my ($msg, @addr) = @_;
2612 interval => 10, 2977
2613 prio => 6, # keep it lowest so it acts like a watchdog 2978 $msg =~ s/\n//;
2614 cb => Coro::unblock_sub { 2979
2615 write_runtime 2980 # limit the # of concurrent backtraces
2616 or warn "ERROR: unable to write runtime file: $!"; 2981 if ($_log_backtrace < 2) {
2982 ++$_log_backtrace;
2983 async {
2984 my @bt = fork_call {
2985 @addr = map { sprintf "%x", $_ } @addr;
2986 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
2987 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
2988 or die "addr2line: $!";
2989
2990 my @funcs;
2991 my @res = <$fh>;
2992 chomp for @res;
2993 while (@res) {
2994 my ($func, $line) = splice @res, 0, 2, ();
2995 push @funcs, "[$func] $line";
2996 }
2997
2998 @funcs
2999 };
3000
3001 LOG llevInfo, "[ABT] $msg\n";
3002 LOG llevInfo, "[ABT] $_\n" for @bt;
3003 --$_log_backtrace;
3004 };
3005 } else {
3006 LOG llevInfo, "[ABT] $msg\n";
3007 LOG llevInfo, "[ABT] [suppressed]\n";
2617 }, 3008 }
2618); 3009}
3010
3011# load additional modules
3012use cf::pod;
2619 3013
2620END { cf::emergency_save } 3014END { cf::emergency_save }
2621 3015
26221 30161
2623 3017

Diff Legend

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