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.176 by root, Sun Jan 14 22:14:35 2007 UTC vs.
Revision 1.268 by root, Tue May 22 10:50:00 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.4 (); 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
25use BDB ();
20use Data::Dumper; 26use Data::Dumper;
21use Digest::MD5; 27use Digest::MD5;
22use Fcntl; 28use Fcntl;
29use YAML::Syck ();
23use IO::AIO 2.32 (); 30use IO::AIO 2.32 ();
24use YAML::Syck ();
25use Time::HiRes; 31use Time::HiRes;
32use Compress::LZF;
26 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
38Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
39
27use 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
28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30 41
31# 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?
32$YAML::Syck::ImplicitUnicode = 1; 43$YAML::Syck::ImplicitUnicode = 1;
33 44
34$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
35 48
36our %COMMAND = (); 49our %COMMAND = ();
37our %COMMAND_TIME = (); 50our %COMMAND_TIME = ();
38 51
39our @EXTS = (); # list of extension package names 52our @EXTS = (); # list of extension package names
40our %EXTCMD = (); 53our %EXTCMD = ();
41our %EXT_CORO = (); # coroutines bound to extensions 54our %EXT_CORO = (); # coroutines bound to extensions
42our %EXT_MAP = (); # pluggable maps 55our %EXT_MAP = (); # pluggable maps
43 56
57our $RELOAD; # number of reloads so far
44our @EVENT; 58our @EVENT;
45our $LIBDIR = datadir . "/ext";
46 59
47our $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(!)
48our $TICK_WATCHER; 73our $TICK_WATCHER;
49our $AIO_POLL_WATCHER; 74our $AIO_POLL_WATCHER;
50our $WRITE_RUNTIME_WATCHER; 75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
51our $NEXT_TICK; 76our $NEXT_TICK;
52our $NOW; 77our $NOW;
78our $USE_FSYNC = 1; # use fsync to write maps - default off
79
80our $BDB_POLL_WATCHER;
81our $DB_ENV;
53 82
54our %CFG; 83our %CFG;
55 84
56our $UPTIME; $UPTIME ||= time; 85our $UPTIME; $UPTIME ||= time;
57our $RUNTIME; 86our $RUNTIME;
58 87
59our %PLAYER; # all users 88our %PLAYER; # all users
60our %MAP; # all maps 89our %MAP; # all maps
61our $LINK_MAP; # the special {link} map, which is always available 90our $LINK_MAP; # the special {link} map, which is always available
62our $RANDOM_MAPS = cf::localdir . "/random";
63
64our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
65our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
66 91
67# 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 ∕
68our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons 93our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
69 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
70binmode STDOUT; 99binmode STDOUT;
71binmode STDERR; 100binmode STDERR;
72 101
73# read virtual server time, if available 102# read virtual server time, if available
74unless ($RUNTIME || !-e cf::localdir . "/runtime") { 103unless ($RUNTIME || !-e "$LOCALDIR/runtime") {
75 open my $fh, "<", cf::localdir . "/runtime" 104 open my $fh, "<", "$LOCALDIR/runtime"
76 or die "unable to read runtime file: $!"; 105 or die "unable to read runtime file: $!";
77 $RUNTIME = <$fh> + 0.; 106 $RUNTIME = <$fh> + 0.;
78} 107}
79 108
80mkdir cf::localdir; 109mkdir $_
81mkdir cf::localdir . "/" . cf::playerdir; 110 for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
82mkdir cf::localdir . "/" . cf::tmpdir;
83mkdir cf::localdir . "/" . cf::uniquedir;
84mkdir $RANDOM_MAPS;
85 111
86our $EMERGENCY_POSITION; 112our $EMERGENCY_POSITION;
113
114sub cf::map::normalise;
87 115
88############################################################################# 116#############################################################################
89 117
90=head2 GLOBAL VARIABLES 118=head2 GLOBAL VARIABLES
91 119
98=item $cf::RUNTIME 126=item $cf::RUNTIME
99 127
100The 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
101every server tick. 129every server tick.
102 130
103=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
104 134
105The perl library directory, where extensions and cf-specific modules can 135Various directories - "/etc", read-only install directory, perl-library
106be 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.
107 139
108=item $cf::NOW 140=item $cf::NOW
109 141
110The time of the last (current) server tick. 142The time of the last (current) server tick.
111 143
112=item $cf::TICK 144=item $cf::TICK
113 145
114The 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.
115 157
116=item %cf::CFG 158=item %cf::CFG
117 159
118Configuration for the server, loaded from C</etc/crossfire/config>, or 160Configuration for the server, loaded from C</etc/crossfire/config>, or
119from wherever your confdir points to. 161from wherever your confdir points to.
120 162
121=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE 163=item cf::wait_for_tick, cf::wait_for_tick_begin
122 164
123These 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
124or 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
125processing 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.
126window of cpu time available, or simply to synchronise to the server tick.
127 168
128=back 169=back
129 170
130=cut 171=cut
131 172
132BEGIN { 173BEGIN {
133 *CORE::GLOBAL::warn = sub { 174 *CORE::GLOBAL::warn = sub {
134 my $msg = join "", @_; 175 my $msg = join "", @_;
135 utf8::encode $msg;
136 176
137 $msg .= "\n" 177 $msg .= "\n"
138 unless $msg =~ /\n$/; 178 unless $msg =~ /\n$/;
139 179
180 $msg =~ s/([\x00-\x08\x0b-\x1f])/sprintf "\\x%02x", ord $1/ge;
181
182 utf8::encode $msg;
140 LOG llevError, $msg; 183 LOG llevError, $msg;
141 }; 184 };
142} 185}
143 186
144@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 187@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
190 $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;
191 $d 234 $d
192 } || "[unable to dump $_[0]: '$@']"; 235 } || "[unable to dump $_[0]: '$@']";
193} 236}
194 237
195use JSON::Syck (); # TODO# replace by JSON::PC once working 238use JSON::XS qw(to_json from_json); # TODO# replace by JSON::PC once working
196 239
197=item $ref = cf::from_json $json 240=item $ref = cf::from_json $json
198 241
199Converts a JSON string into the corresponding perl data structure. 242Converts a JSON string into the corresponding perl data structure.
200 243
201=cut
202
203sub from_json($) {
204 $JSON::Syck::ImplicitUnicode = 1; # work around JSON::Syck bugs
205 JSON::Syck::Load $_[0]
206}
207
208=item $json = cf::to_json $ref 244=item $json = cf::to_json $ref
209 245
210Converts a perl data structure into its JSON representation. 246Converts a perl data structure into its JSON representation.
211
212=cut
213
214sub to_json($) {
215 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
216 JSON::Syck::Dump $_[0]
217}
218 247
219=item cf::lock_wait $string 248=item cf::lock_wait $string
220 249
221Wait until the given lock is available. See cf::lock_acquire. 250Wait until the given lock is available. See cf::lock_acquire.
222 251
228returned. 257returned.
229 258
230Lock 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
231uses map_find and cf::map::load uses map_load). 260uses map_find and cf::map::load uses map_load).
232 261
262=item $locked = cf::lock_active $string
263
264Return true if the lock is currently active, i.e. somebody has locked it.
265
233=cut 266=cut
234 267
235our %LOCK; 268our %LOCK;
236 269
237sub lock_wait($) { 270sub lock_wait($) {
256 # wake up all waiters, to be on the safe side 289 # wake up all waiters, to be on the safe side
257 $_->ready for @{ delete $LOCK{$key} }; 290 $_->ready for @{ delete $LOCK{$key} };
258 } 291 }
259} 292}
260 293
294sub lock_active($) {
295 my ($key) = @_;
296
297 ! ! $LOCK{$key}
298}
299
261sub freeze_mainloop { 300sub freeze_mainloop {
262 return unless $TICK_WATCHER->is_active; 301 return unless $TICK_WATCHER->is_active;
263 302
264 my $guard = Coro::guard { 303 my $guard = Coro::guard {
265 $TICK_WATCHER->start; 304 $TICK_WATCHER->start;
266 $WRITE_RUNTIME_WATCHER->start;
267 }; 305 };
268 $WRITE_RUNTIME_WATCHER->stop;
269 $TICK_WATCHER->stop; 306 $TICK_WATCHER->stop;
270 $guard 307 $guard
271} 308}
272 309
273=item cf::async { BLOCK } 310=item cf::async { BLOCK }
295 332
296sub sync_job(&) { 333sub sync_job(&) {
297 my ($job) = @_; 334 my ($job) = @_;
298 335
299 if ($Coro::current == $Coro::main) { 336 if ($Coro::current == $Coro::main) {
337 my $time = Event::time;
338
300 # this is the main coro, too bad, we have to block 339 # this is the main coro, too bad, we have to block
301 # till the operation succeeds, freezing the server :/ 340 # till the operation succeeds, freezing the server :/
302 341
303 # TODO: use suspend/resume instead 342 # TODO: use suspend/resume instead
304 # (but this is cancel-safe) 343 # (but this is cancel-safe)
315 354
316 while ($busy) { 355 while ($busy) {
317 Coro::cede or Event::one_event; 356 Coro::cede or Event::one_event;
318 } 357 }
319 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
320 wantarray ? @res : $res[0] 366 wantarray ? @res : $res[0]
321 } else { 367 } else {
322 # we are in another coroutine, how wonderful, everything just works 368 # we are in another coroutine, how wonderful, everything just works
323 369
324 $job->() 370 $job->()
344 390
345 $coro 391 $coro
346} 392}
347 393
348sub write_runtime { 394sub write_runtime {
349 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";
350 405
351 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 406 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
352 or return; 407 or return;
353 408
409 my $value = $cf::RUNTIME + 90 + 10;
354 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock 410 # 10 is the runtime save interval, for a monotonic clock
411 # 60 allows for the watchdog to kill the server.
412
355 (aio_write $fh, 0, (length $value), $value, 0) <= 0 413 (aio_write $fh, 0, (length $value), $value, 0) <= 0
356 and return; 414 and return;
357 415
416 # always fsync - this file is important
358 aio_fsync $fh 417 aio_fsync $fh
359 and return; 418 and return;
360 419
420 # touch it again to show we are up-to-date
421 utime undef, undef, $fh;
422
361 close $fh 423 close $fh
362 or return; 424 or return;
363 425
364 aio_rename "$runtime~", $runtime 426 aio_rename "$runtime~", $runtime
365 and return; 427 and return;
366 428
429 warn "runtime file written.\n";#d#
430
367 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 });
368} 443}
369 444
370=back 445=back
371 446
372=cut 447=cut
552 $registry = $CB_TYPE[$object_type] ||= []; 627 $registry = $CB_TYPE[$object_type] ||= [];
553 628
554 } elsif ($type eq "subtype") { 629 } elsif ($type eq "subtype") {
555 defined $object_type or Carp::croak "subtype specified without type"; 630 defined $object_type or Carp::croak "subtype specified without type";
556 my $object_subtype = shift @arg; 631 my $object_subtype = shift @arg;
557 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 632 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
558 633
559 } elsif ($type eq "package") { 634 } elsif ($type eq "package") {
560 my $pkg = shift @arg; 635 my $pkg = shift @arg;
561 636
562 while (my ($name, $id) = each %cb_id) { 637 while (my ($name, $id) = each %cb_id) {
603 if (ref $_[0]) { 678 if (ref $_[0]) {
604 _object_attach @_; 679 _object_attach @_;
605 } else { 680 } else {
606 _attach shift->_attach_registry, @_; 681 _attach shift->_attach_registry, @_;
607 } 682 }
683 _recalc_want;
608}; 684};
609 685
610# all those should be optimised 686# all those should be optimised
611sub cf::attachable::detach { 687sub cf::attachable::detach {
612 my ($obj, $name) = @_; 688 my ($obj, $name) = @_;
615 delete $obj->{_attachment}{$name}; 691 delete $obj->{_attachment}{$name};
616 reattach ($obj); 692 reattach ($obj);
617 } else { 693 } else {
618 Carp::croak "cannot, currently, detach class attachments"; 694 Carp::croak "cannot, currently, detach class attachments";
619 } 695 }
696 _recalc_want;
620}; 697};
621 698
622sub cf::attachable::attached { 699sub cf::attachable::attached {
623 my ($obj, $name) = @_; 700 my ($obj, $name) = @_;
624 701
747 $filename, length $$rdata, scalar @$objs; 824 $filename, length $$rdata, scalar @$objs;
748 825
749 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) { 826 if (my $fh = aio_open "$filename~", O_WRONLY | O_CREAT, 0600) {
750 chmod SAVE_MODE, $fh; 827 chmod SAVE_MODE, $fh;
751 aio_write $fh, 0, (length $$rdata), $$rdata, 0; 828 aio_write $fh, 0, (length $$rdata), $$rdata, 0;
752 aio_fsync $fh; 829 aio_fsync $fh if $cf::USE_FSYNC;
753 close $fh; 830 close $fh;
754 831
755 if (@$objs) { 832 if (@$objs) {
756 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) { 833 if (my $fh = aio_open "$filename.pst~", O_WRONLY | O_CREAT, 0600) {
757 chmod SAVE_MODE, $fh; 834 chmod SAVE_MODE, $fh;
758 my $data = Storable::nfreeze { version => 1, objs => $objs }; 835 my $data = Storable::nfreeze { version => 1, objs => $objs };
759 aio_write $fh, 0, (length $data), $data, 0; 836 aio_write $fh, 0, (length $data), $data, 0;
760 aio_fsync $fh; 837 aio_fsync $fh if $cf::USE_FSYNC;
761 close $fh; 838 close $fh;
762 aio_rename "$filename.pst~", "$filename.pst"; 839 aio_rename "$filename.pst~", "$filename.pst";
763 } 840 }
764 } else { 841 } else {
765 aio_unlink "$filename.pst"; 842 aio_unlink "$filename.pst";
934Returns the given player object, loading it if necessary (might block). 1011Returns the given player object, loading it if necessary (might block).
935 1012
936=cut 1013=cut
937 1014
938sub playerdir($) { 1015sub playerdir($) {
939 cf::localdir 1016 "$PLAYERDIR/"
940 . "/"
941 . cf::playerdir
942 . "/"
943 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1017 . (ref $_[0] ? $_[0]->ob->name : $_[0])
944} 1018}
945 1019
946sub path($) { 1020sub path($) {
947 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1021 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
948 1022
949 (playerdir $login) . "/$login.pl" 1023 (playerdir $login) . "/playerdata"
950} 1024}
951 1025
952sub find_active($) { 1026sub find_active($) {
953 $cf::PLAYER{$_[0]} 1027 $cf::PLAYER{$_[0]}
954 and $cf::PLAYER{$_[0]}->active 1028 and $cf::PLAYER{$_[0]}->active
957 1031
958sub exists($) { 1032sub exists($) {
959 my ($login) = @_; 1033 my ($login) = @_;
960 1034
961 $cf::PLAYER{$login} 1035 $cf::PLAYER{$login}
962 or cf::sync_job { !aio_stat $login } 1036 or cf::sync_job { !aio_stat path $login }
963} 1037}
964 1038
965sub find($) { 1039sub find($) {
966 return $cf::PLAYER{$_[0]} || do { 1040 return $cf::PLAYER{$_[0]} || do {
967 my $login = $_[0]; 1041 my $login = $_[0];
968 1042
969 my $guard = cf::lock_acquire "user_find:$login"; 1043 my $guard = cf::lock_acquire "user_find:$login";
970 1044
971 $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
972 my $pl = load_pl path $login 1053 my $pl = load_pl path $login
973 or return; 1054 or return;
974 $cf::PLAYER{$login} = $pl 1055 $cf::PLAYER{$login} = $pl
975 } 1056 }
976 } 1057 }
1013 1094
1014=cut 1095=cut
1015 1096
1016sub quit_character { 1097sub quit_character {
1017 my ($pl) = @_; 1098 my ($pl) = @_;
1099
1100 my $name = $pl->ob->name;
1018 1101
1019 $pl->{deny_save} = 1; 1102 $pl->{deny_save} = 1;
1020 $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
1021 1104
1022 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1105 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1027 my $path = playerdir $pl; 1110 my $path = playerdir $pl;
1028 my $temp = "$path~$cf::RUNTIME~deleting~"; 1111 my $temp = "$path~$cf::RUNTIME~deleting~";
1029 aio_rename $path, $temp; 1112 aio_rename $path, $temp;
1030 delete $cf::PLAYER{$pl->ob->name}; 1113 delete $cf::PLAYER{$pl->ob->name};
1031 $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
1032 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;
1033} 1136}
1034 1137
1035=item cf::player::list_logins 1138=item cf::player::list_logins
1036 1139
1037Returns 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
1038while and may block, so not sync_job-capable, ever. 1141while and may block, so not sync_job-capable, ever.
1039 1142
1040=cut 1143=cut
1041 1144
1042sub list_logins { 1145sub list_logins {
1043 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1146 my $dirs = aio_readdir $PLAYERDIR
1044 or return []; 1147 or return [];
1045 1148
1046 my @logins; 1149 my @logins;
1047 1150
1048 for my $login (@$dirs) { 1151 for my $login (@$dirs) {
1065=cut 1168=cut
1066 1169
1067sub maps($) { 1170sub maps($) {
1068 my ($pl) = @_; 1171 my ($pl) = @_;
1069 1172
1173 $pl = ref $pl ? $pl->ob->name : $pl;
1174
1070 my $files = aio_readdir playerdir $pl 1175 my $files = aio_readdir playerdir $pl
1071 or return; 1176 or return;
1072 1177
1073 my @paths; 1178 my @paths;
1074 1179
1075 for (@$files) { 1180 for (@$files) {
1076 utf8::decode $_; 1181 utf8::decode $_;
1077 next if /\.(?:pl|pst)$/; 1182 next if /\.(?:pl|pst)$/;
1078 next unless /^$PATH_SEP/o; 1183 next unless /^$PATH_SEP/o;
1079 1184
1080 s/\.map$//; 1185 push @paths, cf::map::normalise "~$pl/$_";
1081 push @paths, "~" . $pl->ob->name . "/" . $_;
1082 } 1186 }
1083 1187
1084 \@paths 1188 \@paths
1085} 1189}
1086 1190
1087=item $player->ext_reply ($msgid, $msgtype, %msg) 1191=item $player->ext_reply ($msgid, %msg)
1088 1192
1089Sends an ext reply to the player. 1193Sends an ext reply to the player.
1090 1194
1091=cut 1195=cut
1092 1196
1093sub ext_reply($$$%) { 1197sub ext_reply($$%) {
1094 my ($self, $id, %msg) = @_; 1198 my ($self, $id, %msg) = @_;
1095 1199
1096 $msg{msgid} = $id; 1200 $msg{msgid} = $id;
1097 1201
1098 $self->send ("ext " . cf::to_json \%msg); 1202 $self->send ("ext " . cf::to_json \%msg);
1099} 1203}
1100 1204
1101package 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}
1102 1245
1103=back 1246=back
1104
1105 1247
1106=head3 cf::map 1248=head3 cf::map
1107 1249
1108=over 4 1250=over 4
1109 1251
1121our $MAX_RESET = 3600; 1263our $MAX_RESET = 3600;
1122our $DEFAULT_RESET = 3000; 1264our $DEFAULT_RESET = 3000;
1123 1265
1124sub generate_random_map { 1266sub generate_random_map {
1125 my ($self, $rmp) = @_; 1267 my ($self, $rmp) = @_;
1126
1127 # mit "rum" bekleckern, nicht 1268 # mit "rum" bekleckern, nicht
1128 $self->_create_random_map ( 1269 $self->_create_random_map (
1129 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle}, 1270 $rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1130 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle}, 1271 $rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1131 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map}, 1272 $rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1138 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used}, 1279 $rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1139 (cf::region::find $rmp->{region}), $rmp->{custom} 1280 (cf::region::find $rmp->{region}), $rmp->{custom}
1140 ) 1281 )
1141} 1282}
1142 1283
1284=item cf::map->register ($regex, $prio)
1285
1286Register a handler for the map path matching the given regex at the
1287givne priority (higher is better, built-in handlers have priority 0, the
1288default).
1289
1290=cut
1291
1143sub register { 1292sub register {
1144 my (undef, $regex) = @_; 1293 my (undef, $regex, $prio) = @_;
1145 my $pkg = caller; 1294 my $pkg = caller;
1146 1295
1147 no strict; 1296 no strict;
1148 push @{"$pkg\::ISA"}, __PACKAGE__; 1297 push @{"$pkg\::ISA"}, __PACKAGE__;
1149 1298
1150 $EXT_MAP{$pkg} = qr<$regex>; 1299 $EXT_MAP{$pkg} = [$prio, qr<$regex>];
1151} 1300}
1152 1301
1153# also paths starting with '/' 1302# also paths starting with '/'
1154$EXT_MAP{"cf::map"} = qr{^(?=/)}; 1303$EXT_MAP{"cf::map"} = [0, qr{^(?=/)}];
1155 1304
1156sub thawer_merge { 1305sub thawer_merge {
1157 my ($self, $merge) = @_; 1306 my ($self, $merge) = @_;
1158 1307
1159 # we have to keep some variables in memory intact 1308 # we have to keep some variables in memory intact
1165 $self->SUPER::thawer_merge ($merge); 1314 $self->SUPER::thawer_merge ($merge);
1166} 1315}
1167 1316
1168sub normalise { 1317sub normalise {
1169 my ($path, $base) = @_; 1318 my ($path, $base) = @_;
1319
1320 $path = "$path"; # make sure its a string
1321
1322 $path =~ s/\.map$//;
1170 1323
1171 # map plan: 1324 # map plan:
1172 # 1325 #
1173 # /! non-realised random map exit (special hack!) 1326 # /! non-realised random map exit (special hack!)
1174 # {... are special paths that are not being touched 1327 # {... are special paths that are not being touched
1202 1355
1203 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object 1356 return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
1204 1357
1205 $path = normalise $path, $base; 1358 $path = normalise $path, $base;
1206 1359
1207 for my $pkg (keys %EXT_MAP) { 1360 for my $pkg (sort { $EXT_MAP{$b}[0] <=> $EXT_MAP{$a}[0] } keys %EXT_MAP) {
1208 if ($path =~ $EXT_MAP{$pkg}) { 1361 if ($path =~ $EXT_MAP{$pkg}[1]) {
1209 my $self = bless cf::map::new, $pkg; 1362 my $self = bless cf::map::new, $pkg;
1210 $self->{path} = $path; $self->path ($path); 1363 $self->{path} = $path; $self->path ($path);
1211 $self->init; # pass $1 etc. 1364 $self->init; # pass $1 etc.
1212 return $self; 1365 return $self;
1213 } 1366 }
1214 } 1367 }
1215 1368
1216 Carp::carp "unable to resolve path '$path'."; 1369 Carp::carp "unable to resolve path '$path' (base '$base').";
1217 () 1370 ()
1218} 1371}
1219 1372
1220sub init { 1373sub init {
1221 my ($self) = @_; 1374 my ($self) = @_;
1236 1389
1237# the original (read-only) location 1390# the original (read-only) location
1238sub load_path { 1391sub load_path {
1239 my ($self) = @_; 1392 my ($self) = @_;
1240 1393
1241 sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path} 1394 "$MAPDIR/$self->{path}.map"
1242} 1395}
1243 1396
1244# the temporary/swap location 1397# the temporary/swap location
1245sub save_path { 1398sub save_path {
1246 my ($self) = @_; 1399 my ($self) = @_;
1247 1400
1248 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1401 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1249 sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path 1402 "$TMPDIR/$path.map"
1250} 1403}
1251 1404
1252# the unique path, undef == no special unique path 1405# the unique path, undef == no special unique path
1253sub uniq_path { 1406sub uniq_path {
1254 my ($self) = @_; 1407 my ($self) = @_;
1255 1408
1256 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1409 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1257 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1410 "$UNIQUEDIR/$path"
1258} 1411}
1259 1412
1260# and all this just because we cannot iterate over 1413# and all this just because we cannot iterate over
1261# all maps in C++... 1414# all maps in C++...
1262sub change_all_map_light { 1415sub change_all_map_light {
1276 1429
1277sub load_header_from($) { 1430sub load_header_from($) {
1278 my ($self, $path) = @_; 1431 my ($self, $path) = @_;
1279 1432
1280 utf8::encode $path; 1433 utf8::encode $path;
1281 aio_open $path, O_RDONLY, 0 1434 #aio_open $path, O_RDONLY, 0
1282 or return; 1435 # or return;
1283 1436
1284 $self->_load_header ($path) 1437 $self->_load_header ($path)
1285 or return; 1438 or return;
1286 1439
1287 $self->{load_path} = $path; 1440 $self->{load_path} = $path;
1288 1441
1289 1 1442 1
1290} 1443}
1291 1444
1292sub load_orig { 1445sub load_header_orig {
1293 my ($self) = @_; 1446 my ($self) = @_;
1294 1447
1295 $self->load_header_from ($self->load_path) 1448 $self->load_header_from ($self->load_path)
1296} 1449}
1297 1450
1298sub load_temp { 1451sub load_header_temp {
1299 my ($self) = @_; 1452 my ($self) = @_;
1300 1453
1301 $self->load_header_from ($self->save_path) 1454 $self->load_header_from ($self->save_path)
1455}
1456
1457sub prepare_temp {
1458 my ($self) = @_;
1459
1460 $self->last_access ((delete $self->{last_access})
1461 || $cf::RUNTIME); #d#
1462 # safety
1463 $self->{instantiate_time} = $cf::RUNTIME
1464 if $self->{instantiate_time} > $cf::RUNTIME;
1465}
1466
1467sub prepare_orig {
1468 my ($self) = @_;
1469
1470 $self->{load_original} = 1;
1471 $self->{instantiate_time} = $cf::RUNTIME;
1472 $self->last_access ($cf::RUNTIME);
1473 $self->instantiate;
1302} 1474}
1303 1475
1304sub load_header { 1476sub load_header {
1305 my ($self) = @_; 1477 my ($self) = @_;
1306 1478
1307 if ($self->load_temp) { 1479 if ($self->load_header_temp) {
1308 $self->last_access ((delete $self->{last_access}) 1480 $self->prepare_temp;
1309 || $cf::RUNTIME); #d#
1310 # safety
1311 $self->{instantiate_time} = $cf::RUNTIME
1312 if $self->{instantiate_time} > $cf::RUNTIME;
1313 } else { 1481 } else {
1314 $self->load_orig 1482 $self->load_header_orig
1315 or return; 1483 or return;
1316 1484 $self->prepare_orig;
1317 $self->{load_original} = 1;
1318 $self->{instantiate_time} = $cf::RUNTIME;
1319 $self->last_access ($cf::RUNTIME);
1320 $self->instantiate;
1321 } 1485 }
1486
1487 $self->default_region (cf::region::find_by_path $self->{path})
1488 unless $self->default_region;
1322 1489
1323 1 1490 1
1324} 1491}
1325 1492
1326sub find; 1493sub find;
1339 $map->{last_save} = $cf::RUNTIME; 1506 $map->{last_save} = $cf::RUNTIME;
1340 1507
1341 $map->load_header 1508 $map->load_header
1342 or return; 1509 or return;
1343 1510
1344 if ($map->should_reset) { 1511 if ($map->should_reset && 0) {#d#TODO# disabled, crashy (locking issue?)
1512 # doing this can freeze the server in a sync job, obviously
1345 $cf::WAIT_FOR_TICK->wait; 1513 #$cf::WAIT_FOR_TICK->wait;
1346 $map->reset; 1514 $map->reset;
1347 undef $guard; 1515 undef $guard;
1348 $map = find $path 1516 return find $path;
1349 or return;
1350 } 1517 }
1351 1518
1352 $cf::MAP{$path} = $map 1519 $cf::MAP{$path} = $map
1353 } 1520 }
1354} 1521}
1522
1523sub pre_load { }
1524sub post_load { }
1355 1525
1356sub load { 1526sub load {
1357 my ($self) = @_; 1527 my ($self) = @_;
1358 1528
1529 local $self->{deny_reset} = 1; # loading can take a long time
1530
1359 my $path = $self->{path}; 1531 my $path = $self->{path};
1532
1533 {
1360 my $guard = cf::lock_acquire "map_load:$path"; 1534 my $guard = cf::lock_acquire "map_load:$path";
1361 1535
1362 return if $self->in_memory != cf::MAP_SWAPPED; 1536 return if $self->in_memory != cf::MAP_SWAPPED;
1363 1537
1364 $self->in_memory (cf::MAP_LOADING); 1538 $self->in_memory (cf::MAP_LOADING);
1365 1539
1366 $self->alloc; 1540 $self->alloc;
1367 $self->_load_objects ($self->{load_path}, 1)
1368 or return;
1369 1541
1370 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1) 1542 $self->pre_load;
1371 if delete $self->{load_original};
1372
1373 if (my $uniq = $self->uniq_path) {
1374 utf8::encode $uniq;
1375 if (aio_open $uniq, O_RDONLY, 0) {
1376 $self->clear_unique_items;
1377 $self->_load_objects ($uniq, 0);
1378 }
1379 }
1380
1381 Coro::cede;
1382
1383 # now do the right thing for maps
1384 $self->link_multipart_objects;
1385
1386 unless ($self->{deny_activate}) {
1387 $self->decay_objects;
1388 $self->fix_auto_apply;
1389 $self->update_buttons;
1390 Coro::cede; 1543 Coro::cede;
1391 $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;
1392 $self->difficulty ($self->estimate_difficulty) 1562 $self->difficulty ($self->estimate_difficulty)
1393 unless $self->difficulty; 1563 unless $self->difficulty;
1394 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;
1395 $self->activate; 1573 $self->activate;
1396 } 1574 }
1397 1575
1398 $self->in_memory (cf::MAP_IN_MEMORY); 1576 $self->in_memory (cf::MAP_IN_MEMORY);
1577 }
1578
1579 $self->post_load;
1399} 1580}
1400 1581
1401sub customise_for { 1582sub customise_for {
1402 my ($self, $ob) = @_; 1583 my ($self, $ob) = @_;
1403 1584
1442 1623
1443 cf::sync_job { $map->load }; 1624 cf::sync_job { $map->load };
1444} 1625}
1445 1626
1446our %MAP_PREFETCH; 1627our %MAP_PREFETCH;
1447our $MAP_PREFETCHER = Coro::async { 1628our $MAP_PREFETCHER = undef;
1448 while () {
1449 for my $path (keys %MAP_PREFETCH) {
1450 my $map = find $path
1451 or next;
1452 $map->load;
1453
1454 delete $MAP_PREFETCH{$path};
1455 }
1456 Coro::schedule;
1457 }
1458};
1459 1629
1460sub find_async { 1630sub find_async {
1461 my ($path, $origin) = @_; 1631 my ($path, $origin) = @_;
1462 1632
1463 $path = normalise $path, $origin && $origin->{path}; 1633 $path = normalise $path, $origin && $origin->{path};
1464 1634
1465 if (my $map = $cf::MAP{$path}) { 1635 if (my $map = $cf::MAP{$path}) {
1466 return $map if $map->in_memory == cf::MAP_IN_MEMORY; 1636 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1467 } 1637 }
1468 1638
1469 $MAP_PREFETCH{$path} = 0; 1639 undef $MAP_PREFETCH{$path};
1640 $MAP_PREFETCHER ||= cf::async {
1641 while (%MAP_PREFETCH) {
1642 for my $path (keys %MAP_PREFETCH) {
1643 my $map = find $path
1644 or next;
1645 $map->load;
1646
1647 delete $MAP_PREFETCH{$path};
1648 }
1649 }
1650 undef $MAP_PREFETCHER;
1651 };
1470 $MAP_PREFETCHER->ready; 1652 $MAP_PREFETCHER->prio (6);
1471 1653
1472 () 1654 ()
1473} 1655}
1474 1656
1475sub save { 1657sub save {
1545 return if $self->players; 1727 return if $self->players;
1546 return if $self->isa ("ext::map_per_player");#d# 1728 return if $self->isa ("ext::map_per_player");#d#
1547 1729
1548 warn "resetting map ", $self->path;#d# 1730 warn "resetting map ", $self->path;#d#
1549 1731
1732 $self->in_memory (cf::MAP_SWAPPED);
1733
1734 # need to save uniques path
1735 unless ($self->{deny_save}) {
1736 my $uniq = $self->uniq_path; utf8::encode $uniq;
1737
1738 $self->_save_objects ($uniq, cf::IO_UNIQUES)
1739 if $uniq;
1740 }
1741
1550 delete $cf::MAP{$self->path}; 1742 delete $cf::MAP{$self->path};
1551 1743
1552 $self->in_memory (cf::MAP_SWAPPED);
1553 $self->clear; 1744 $self->clear;
1554 1745
1555 $_->clear_links_to ($self) for values %cf::MAP; 1746 $_->clear_links_to ($self) for values %cf::MAP;
1556 1747
1557 $self->unlink_save; 1748 $self->unlink_save;
1584instantiated unique items. May block. 1775instantiated unique items. May block.
1585 1776
1586=cut 1777=cut
1587 1778
1588sub unique_maps() { 1779sub unique_maps() {
1589 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 1780 my $files = aio_readdir $UNIQUEDIR
1590 or return; 1781 or return;
1591 1782
1592 my @paths; 1783 my @paths;
1593 1784
1594 for (@$files) { 1785 for (@$files) {
1595 utf8::decode $_; 1786 utf8::decode $_;
1596 next if /\.pst$/; 1787 next if /\.pst$/;
1597 next unless /^$PATH_SEP/o; 1788 next unless /^$PATH_SEP/o;
1598 1789
1599 s/\.map$//; 1790 push @paths, cf::map::normalise $_;
1600 push @paths, $_;
1601 } 1791 }
1602 1792
1603 \@paths 1793 \@paths
1604} 1794}
1605 1795
1699=cut 1889=cut
1700 1890
1701sub link_map { 1891sub link_map {
1702 unless ($LINK_MAP) { 1892 unless ($LINK_MAP) {
1703 $LINK_MAP = cf::map::find "{link}" 1893 $LINK_MAP = cf::map::find "{link}"
1704 or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 }; 1894 or cf::cleanup "FATAL: unable to provide {link} map, exiting.";
1705 $LINK_MAP->load; 1895 $LINK_MAP->load;
1706 } 1896 }
1707 1897
1708 $LINK_MAP 1898 $LINK_MAP
1709} 1899}
1716 return if UNIVERSAL::isa $self->map, "ext::map_link"; 1906 return if UNIVERSAL::isa $self->map, "ext::map_link";
1717 1907
1718 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y] 1908 $self->{_link_pos} ||= [$self->map->{path}, $self->x, $self->y]
1719 if $self->map; 1909 if $self->map;
1720 1910
1721 $self->enter_map ($LINK_MAP || link_map, 20, 20); 1911 $self->enter_map ($LINK_MAP || link_map, 10, 10);
1722} 1912}
1723 1913
1724sub cf::object::player::leave_link { 1914sub cf::object::player::leave_link {
1725 my ($self, $map, $x, $y) = @_; 1915 my ($self, $map, $x, $y) = @_;
1726 1916
1748 $map->load; 1938 $map->load;
1749 $map->load_diag; 1939 $map->load_diag;
1750 1940
1751 return unless $self->contr->active; 1941 return unless $self->contr->active;
1752 $self->activate_recursive; 1942 $self->activate_recursive;
1943
1944 local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
1753 $self->enter_map ($map, $x, $y); 1945 $self->enter_map ($map, $x, $y);
1754} 1946}
1755 1947
1756cf::player->attach ( 1948cf::player->attach (
1757 on_logout => sub { 1949 on_logout => sub {
1770 # try to abort aborted map switching on player login :) 1962 # try to abort aborted map switching on player login :)
1771 # should happen only on crashes 1963 # should happen only on crashes
1772 if ($pl->ob->{_link_pos}) { 1964 if ($pl->ob->{_link_pos}) {
1773 $pl->ob->enter_link; 1965 $pl->ob->enter_link;
1774 (async { 1966 (async {
1775 # we need this sleep as the login has a concurrent enter_exit running
1776 # and this sleep increases chances of the player not ending up in scorn
1777 $pl->ob->reply (undef, 1967 $pl->ob->reply (undef,
1778 "There was an internal problem at your last logout, " 1968 "There was an internal problem at your last logout, "
1779 . "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.",
1780 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
1781 Coro::Timer::sleep 1; 1973 Coro::Timer::sleep 1;
1782 $pl->ob->leave_link; 1974 $pl->ob->leave_link;
1783 })->prio (2); 1975 })->prio (2);
1784 } 1976 }
1785 }, 1977 },
1786); 1978);
1787 1979
1788=item $player_object->goto ($path, $x, $y) 1980=item $player_object->goto ($path, $x, $y[, $check->($map)])
1981
1982Moves the player to the given map-path and coordinates by first freezing
1983her, loading and preparing them map, calling the provided $check callback
1984that has to return the map if sucecssful, and then unfreezes the player on
1985the new (success) or old (failed) map position.
1789 1986
1790=cut 1987=cut
1791 1988
1792sub cf::object::player::goto { 1989sub cf::object::player::goto {
1793 my ($self, $path, $x, $y) = @_; 1990 my ($self, $path, $x, $y, $check) = @_;
1991
1992 #d# #TODO#
1993 if ($check && !ref $check) {
1994 warn Carp::longmess "goto called with non-ref check argument";#d#
1995 undef $check;
1996 }
1794 1997
1795 $self->enter_link; 1998 $self->enter_link;
1796 1999
1797 (async { 2000 (async {
2001 my $map = eval {
1798 my $map = cf::map::find $path; 2002 my $map = cf::map::find $path;
2003
2004 if ($map) {
1799 $map = $map->customise_for ($self) if $map; 2005 $map = $map->customise_for ($self);
1800 2006 $map = $check->($map) if $check && $map;
1801# warn "entering ", $map->path, " at ($x, $y)\n" 2007 } else {
1802# if $map;
1803
1804 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED); 2008 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2009 }
2010
2011 $map
2012 };
2013
2014 if ($@) {
2015 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2016 LOG llevError | logBacktrace, Carp::longmess $@;
2017 }
1805 2018
1806 $self->leave_link ($map, $x, $y); 2019 $self->leave_link ($map, $x, $y);
1807 })->prio (1); 2020 })->prio (1);
1808} 2021}
1809 2022
1813 2026
1814sub parse_random_map_params { 2027sub parse_random_map_params {
1815 my ($spec) = @_; 2028 my ($spec) = @_;
1816 2029
1817 my $rmp = { # defaults 2030 my $rmp = { # defaults
1818 xsize => 10, 2031 xsize => (cf::rndm 15, 40),
1819 ysize => 10, 2032 ysize => (cf::rndm 15, 40),
2033 symmetry => (cf::rndm 1, cf::SYMMETRY_XY),
2034 #layout => string,
1820 }; 2035 };
1821 2036
1822 for (split /\n/, $spec) { 2037 for (split /\n/, $spec) {
1823 my ($k, $v) = split /\s+/, $_, 2; 2038 my ($k, $v) = split /\s+/, $_, 2;
1824 2039
1828 $rmp 2043 $rmp
1829} 2044}
1830 2045
1831sub prepare_random_map { 2046sub prepare_random_map {
1832 my ($exit) = @_; 2047 my ($exit) = @_;
2048
2049 my $guard = cf::lock_acquire "exit_prepare:$exit";
1833 2050
1834 # all this does is basically replace the /! path by 2051 # all this does is basically replace the /! path by
1835 # a new random map path (?random/...) with a seed 2052 # a new random map path (?random/...) with a seed
1836 # that depends on the exit object 2053 # that depends on the exit object
1837 2054
1838 my $rmp = parse_random_map_params $exit->msg; 2055 my $rmp = parse_random_map_params $exit->msg;
1839 2056
1840 if ($exit->map) { 2057 if ($exit->map) {
1841 $rmp->{region} = $exit->map->region_name; 2058 $rmp->{region} = $exit->region->name;
1842 $rmp->{origin_map} = $exit->map->path; 2059 $rmp->{origin_map} = $exit->map->path;
1843 $rmp->{origin_x} = $exit->x; 2060 $rmp->{origin_x} = $exit->x;
1844 $rmp->{origin_y} = $exit->y; 2061 $rmp->{origin_y} = $exit->y;
1845 } 2062 }
1846 2063
1847 $rmp->{random_seed} ||= $exit->random_seed; 2064 $rmp->{random_seed} ||= $exit->random_seed;
1848 2065
1849 my $data = cf::to_json $rmp; 2066 my $data = cf::to_json $rmp;
1850 my $md5 = Digest::MD5::md5_hex $data; 2067 my $md5 = Digest::MD5::md5_hex $data;
2068 my $meta = "$RANDOMDIR/$md5.meta";
1851 2069
1852 if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY | O_CREAT, 0666) { 2070 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1853 aio_write $fh, 0, (length $data), $data, 0; 2071 aio_write $fh, 0, (length $data), $data, 0;
2072 undef $fh;
2073 aio_rename "$meta~", $meta;
1854 2074
1855 $exit->slaying ("?random/$md5"); 2075 $exit->slaying ("?random/$md5");
1856 $exit->msg (undef); 2076 $exit->msg (undef);
1857 } 2077 }
1858} 2078}
1859 2079
1860sub cf::object::player::enter_exit { 2080sub cf::object::player::enter_exit {
1861 my ($self, $exit) = @_; 2081 my ($self, $exit) = @_;
1862 2082
1863 return unless $self->type == cf::PLAYER; 2083 return unless $self->type == cf::PLAYER;
2084
2085 if ($exit->slaying eq "/!") {
2086 #TODO: this should de-fi-ni-te-ly not be a sync-job
2087 # the problem is that $exit might not survive long enough
2088 # so it needs to be done right now, right here
2089 cf::sync_job { prepare_random_map $exit };
2090 }
2091
2092 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
2093 my $hp = $exit->stats->hp;
2094 my $sp = $exit->stats->sp;
1864 2095
1865 $self->enter_link; 2096 $self->enter_link;
1866 2097
1867 (async { 2098 (async {
1868 $self->deactivate_recursive; # just to be sure 2099 $self->deactivate_recursive; # just to be sure
1869 unless (eval { 2100 unless (eval {
1870 prepare_random_map $exit 2101 $self->goto ($slaying, $hp, $sp);
1871 if $exit->slaying eq "/!";
1872
1873 my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1874 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1875 2102
1876 1; 2103 1;
1877 }) { 2104 }) {
1878 $self->message ("Something went wrong deep within the crossfire server. " 2105 $self->message ("Something went wrong deep within the crossfire server. "
1879 . "I'll try to bring you back to the map you were before. " 2106 . "I'll try to bring you back to the map you were before. "
1880 . "Please report this to the dungeon master!", 2107 . "Please report this to the dungeon master!",
1881 cf::NDI_UNIQUE | cf::NDI_RED); 2108 cf::NDI_UNIQUE | cf::NDI_RED);
1882 2109
1883 warn "ERROR in enter_exit: $@"; 2110 warn "ERROR in enter_exit: $@";
1884 $self->leave_link; 2111 $self->leave_link;
1885 } 2112 }
1886 })->prio (1); 2113 })->prio (1);
1899 2126
1900sub cf::client::send_drawinfo { 2127sub cf::client::send_drawinfo {
1901 my ($self, $text, $flags) = @_; 2128 my ($self, $text, $flags) = @_;
1902 2129
1903 utf8::encode $text; 2130 utf8::encode $text;
1904 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2131 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1905} 2132}
1906 2133
2134=item $client->ext_event ($type, %msg)
2135
2136Sends an exti event to the client.
2137
2138=cut
2139
2140sub cf::client::ext_event($$%) {
2141 my ($self, $type, %msg) = @_;
2142
2143 $msg{msgtype} = "event_$type";
2144 $self->send_packet ("ext " . cf::to_json \%msg);
2145}
1907 2146
1908=item $success = $client->query ($flags, "text", \&cb) 2147=item $success = $client->query ($flags, "text", \&cb)
1909 2148
1910Queues a query to the client, calling the given callback with 2149Queues a query to the client, calling the given callback with
1911the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2150the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
1940 # get handled first 2179 # get handled first
1941 my $queue = delete $ns->{query_queue} 2180 my $queue = delete $ns->{query_queue}
1942 or return; # be conservative, not sure how that can happen, but we saw a crash here 2181 or return; # be conservative, not sure how that can happen, but we saw a crash here
1943 2182
1944 (shift @$queue)->[1]->($msg); 2183 (shift @$queue)->[1]->($msg);
2184 return unless $ns->valid; # temporary(?) workaround for callback destroying socket
1945 2185
1946 push @{ $ns->{query_queue} }, @$queue; 2186 push @{ $ns->{query_queue} }, @$queue;
1947 2187
1948 if (@{ $ns->{query_queue} } == @$queue) { 2188 if (@{ $ns->{query_queue} } == @$queue) {
1949 if (@$queue) { 2189 if (@$queue) {
2007 2247
2008# here we export the classes and methods available to script code 2248# here we export the classes and methods available to script code
2009 2249
2010=pod 2250=pod
2011 2251
2012The following fucntions and emthods are available within a safe environment: 2252The following functions and methods are available within a safe environment:
2013 2253
2014 cf::object contr pay_amount pay_player map 2254 cf::object contr pay_amount pay_player map
2015 cf::object::player player 2255 cf::object::player player
2016 cf::player peaceful 2256 cf::player peaceful
2017 cf::map trigger 2257 cf::map trigger
2102############################################################################# 2342#############################################################################
2103 2343
2104=head2 EXTENSION DATABASE SUPPORT 2344=head2 EXTENSION DATABASE SUPPORT
2105 2345
2106Crossfire maintains a very simple database for extension use. It can 2346Crossfire maintains a very simple database for extension use. It can
2107currently store anything that can be serialised using Storable, which 2347currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2108excludes objects. 2348convert to/from binary).
2109 2349
2110The parameter C<$family> should best start with the name of the extension 2350The parameter C<$family> should best start with the name of the extension
2111using it, it should be unique. 2351using it, it should be unique.
2112 2352
2113=over 4 2353=over 4
2114 2354
2115=item $hashref = cf::db_get $family
2116
2117Return a hashref for use by the extension C<$family>, which can be
2118modified. After modifications, you have to call C<cf::db_dirty> or
2119C<cf::db_sync>.
2120
2121=item $value = cf::db_get $family => $key 2355=item $value = cf::db_get $family => $key
2122 2356
2123Returns a single value from the database 2357Returns a single value from the database.
2124
2125=item cf::db_put $family => $hashref
2126
2127Stores the given family hashref into the database. Updates are delayed, if
2128you want the data to be synced to disk immediately, use C<cf::db_sync>.
2129 2358
2130=item cf::db_put $family => $key => $value 2359=item cf::db_put $family => $key => $value
2131 2360
2132Stores the given C<$value> in the family hash. Updates are delayed, if you 2361Stores the given C<$value> in the family.
2133want the data to be synced to disk immediately, use C<cf::db_sync>.
2134
2135=item cf::db_dirty
2136
2137Marks the database as dirty, to be updated at a later time.
2138
2139=item cf::db_sync
2140
2141Immediately write the database to disk I<if it is dirty>.
2142 2362
2143=cut 2363=cut
2144 2364
2145our $DB; 2365our $DB;
2146 2366
2147{ 2367sub db_init {
2148 my $path = cf::localdir . "/database.pst"; 2368 unless ($DB) {
2369 $DB = BDB::db_create $DB_ENV;
2149 2370
2150 sub db_load() { 2371 cf::sync_job {
2151 $DB = stat $path ? Storable::retrieve $path : { }; 2372 eval {
2152 } 2373 $DB->set_flags (BDB::CHKSUM);
2153 2374
2154 my $pid; 2375 BDB::db_open $DB, undef, "db", undef, BDB::BTREE,
2155 2376 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2156 sub db_save() { 2377 cf::cleanup "db_open(db): $!" if $!;
2157 waitpid $pid, 0 if $pid; 2378 };
2158 if (0 == ($pid = fork)) { 2379 cf::cleanup "db_open(db): $@" if $@;
2159 $DB->{_meta}{version} = 1;
2160 Storable::nstore $DB, "$path~";
2161 rename "$path~", $path;
2162 cf::_exit 0 if defined $pid;
2163 } 2380 };
2164 }
2165
2166 my $dirty;
2167
2168 sub db_sync() {
2169 db_save if $dirty;
2170 undef $dirty;
2171 }
2172
2173 my $idle = Event->idle (min => $TICK * 2.8, max => 10, repeat => 0, data => WF_AUTOCANCEL, cb => sub {
2174 db_sync;
2175 }); 2381 }
2382}
2176 2383
2177 sub db_dirty() {
2178 $dirty = 1;
2179 $idle->start;
2180 }
2181
2182 sub db_get($;$) { 2384sub db_get($$) {
2183 @_ >= 2 2385 my $key = "$_[0]/$_[1]";
2184 ? $DB->{$_[0]}{$_[1]}
2185 : ($DB->{$_[0]} ||= { })
2186 }
2187 2386
2387 cf::sync_job {
2388 BDB::db_get $DB, undef, $key, my $data;
2389
2390 $! ? ()
2391 : $data
2392 }
2393}
2394
2188 sub db_put($$;$) { 2395sub db_put($$$) {
2189 if (@_ >= 3) { 2396 BDB::dbreq_pri 4;
2190 $DB->{$_[0]}{$_[1]} = $_[2]; 2397 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2191 } else { 2398}
2192 $DB->{$_[0]} = $_[1];
2193 }
2194 db_dirty;
2195 }
2196 2399
2197 cf::global->attach ( 2400=item cf::cache $id => [$paths...], $processversion => $process
2198 prio => 10000, 2401
2199 on_cleanup => sub { 2402Generic caching function that returns the value of the resource $id,
2200 db_sync; 2403caching and regenerating as required.
2404
2405This function can block.
2406
2407=cut
2408
2409sub cache {
2410 my ($id, $src, $processversion, $process) = @_;
2411
2412 my $meta =
2413 join "\x00",
2414 $processversion,
2415 map {
2416 aio_stat $_
2417 and Carp::croak "$_: $!";
2418
2419 ($_, (stat _)[7,9])
2420 } @$src;
2421
2422 my $dbmeta = db_get cache => "$id/meta";
2423 if ($dbmeta ne $meta) {
2424 # changed, we may need to process
2425
2426 my @data;
2427 my $md5;
2428
2429 for (0 .. $#$src) {
2430 0 <= aio_load $src->[$_], $data[$_]
2431 or Carp::croak "$src->[$_]: $!";
2201 }, 2432 }
2202 ); 2433
2434 # if processing is expensive, check
2435 # checksum first
2436 if (1) {
2437 $md5 =
2438 join "\x00",
2439 $processversion,
2440 map {
2441 Coro::cede;
2442 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2443 } 0.. $#$src;
2444
2445
2446 my $dbmd5 = db_get cache => "$id/md5";
2447 if ($dbmd5 eq $md5) {
2448 db_put cache => "$id/meta", $meta;
2449
2450 return db_get cache => "$id/data";
2451 }
2452 }
2453
2454 my $t1 = Time::HiRes::time;
2455 my $data = $process->(\@data);
2456 my $t2 = Time::HiRes::time;
2457
2458 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2459
2460 db_put cache => "$id/data", $data;
2461 db_put cache => "$id/md5" , $md5;
2462 db_put cache => "$id/meta", $meta;
2463
2464 return $data;
2465 }
2466
2467 db_get cache => "$id/data"
2203} 2468}
2469
2470=item fork_call { }, $args
2471
2472Executes the given code block with the given arguments in a seperate
2473process, returning the results. Everything must be serialisable with
2474Coro::Storable. May, of course, block. Note that the executed sub may
2475never block itself or use any form of Event handling.
2476
2477=cut
2478
2479sub fork_call(&@) {
2480 my ($cb, @args) = @_;
2481
2482# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2483# or die "socketpair: $!";
2484 pipe my $fh1, my $fh2
2485 or die "pipe: $!";
2486
2487 if (my $pid = fork) {
2488 close $fh2;
2489
2490 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2491 $res = Coro::Storable::thaw $res;
2492
2493 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2494
2495 die $$res unless "ARRAY" eq ref $res;
2496
2497 return wantarray ? @$res : $res->[-1];
2498 } else {
2499 reset_signals;
2500 local $SIG{__WARN__};
2501 local $SIG{__DIE__};
2502 eval {
2503 close $fh1;
2504
2505 my @res = eval { $cb->(@args) };
2506 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2507 };
2508
2509 warn $@ if $@;
2510 _exit 0;
2511 }
2512}
2513
2514
2204 2515
2205############################################################################# 2516#############################################################################
2206# the server's main() 2517# the server's init and main functions
2518
2519sub load_facedata($) {
2520 my ($path) = @_;
2521
2522 warn "loading facedata from $path\n";
2523
2524 my $facedata;
2525 0 < aio_load $path, $facedata
2526 or die "$path: $!";
2527
2528 $facedata = Coro::Storable::thaw $facedata;
2529
2530 $facedata->{version} == 2
2531 or cf::cleanup "$path: version mismatch, cannot proceed.";
2532
2533 {
2534 my $faces = $facedata->{faceinfo};
2535
2536 while (my ($face, $info) = each %$faces) {
2537 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2538 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2539 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2540 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2541 Coro::cede;
2542 }
2543
2544 while (my ($face, $info) = each %$faces) {
2545 next unless $info->{smooth};
2546 my $idx = cf::face::find $face
2547 or next;
2548 if (my $smooth = cf::face::find $info->{smooth}) {
2549 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2550 } else {
2551 warn "smooth face '$info->{smooth}' not found for face '$face'";
2552 }
2553 Coro::cede;
2554 }
2555 }
2556
2557 {
2558 my $anims = $facedata->{animinfo};
2559
2560 while (my ($anim, $info) = each %$anims) {
2561 cf::anim::set $anim, $info->{frames}, $info->{facings};
2562 Coro::cede;
2563 }
2564
2565 cf::anim::invalidate_all; # d'oh
2566 }
2567
2568 1
2569}
2570
2571sub reload_regions {
2572 load_resource_file "$MAPDIR/regions"
2573 or die "unable to load regions file\n";
2574}
2575
2576sub reload_facedata {
2577 load_facedata "$DATADIR/facedata"
2578 or die "unable to load facedata\n";
2579}
2580
2581sub reload_archetypes {
2582 load_resource_file "$DATADIR/archetypes"
2583 or die "unable to load archetypes\n";
2584}
2585
2586sub reload_treasures {
2587 load_resource_file "$DATADIR/treasures"
2588 or die "unable to load treasurelists\n";
2589}
2590
2591sub reload_resources {
2592 warn "reloading resource files...\n";
2593
2594 reload_regions;
2595 reload_facedata;
2596 reload_archetypes;
2597 reload_treasures;
2598
2599 warn "finished reloading resource files\n";
2600}
2601
2602sub init {
2603 reload_resources;
2604}
2207 2605
2208sub cfg_load { 2606sub cfg_load {
2209 open my $fh, "<:utf8", cf::confdir . "/config" 2607 open my $fh, "<:utf8", "$CONFDIR/config"
2210 or return; 2608 or return;
2211 2609
2212 local $/; 2610 local $/;
2213 *CFG = YAML::Syck::Load <$fh>; 2611 *CFG = YAML::Syck::Load <$fh>;
2214 2612
2234 Event::one_event; 2632 Event::one_event;
2235 })->prio (Coro::PRIO_MAX); 2633 })->prio (Coro::PRIO_MAX);
2236 }; 2634 };
2237 2635
2238 cfg_load; 2636 cfg_load;
2239 db_load; 2637 db_init;
2240 load_extensions; 2638 load_extensions;
2639
2640 $TICK_WATCHER->start;
2241 Event::loop; 2641 Event::loop;
2242} 2642}
2243 2643
2244############################################################################# 2644#############################################################################
2245# initialisation and cleanup 2645# initialisation and cleanup
2246 2646
2247# install some emergency cleanup handlers 2647# install some emergency cleanup handlers
2248BEGIN { 2648BEGIN {
2249 for my $signal (qw(INT HUP TERM)) { 2649 for my $signal (qw(INT HUP TERM)) {
2250 Event->signal ( 2650 Event->signal (
2651 reentrant => 0,
2251 data => WF_AUTOCANCEL, 2652 data => WF_AUTOCANCEL,
2252 signal => $signal, 2653 signal => $signal,
2654 prio => 0,
2253 cb => sub { 2655 cb => sub {
2254 cf::cleanup "SIG$signal"; 2656 cf::cleanup "SIG$signal";
2255 }, 2657 },
2256 ); 2658 );
2257 } 2659 }
2258} 2660}
2279 my $map = $cf::MAP{$path} or next; 2681 my $map = $cf::MAP{$path} or next;
2280 $map->valid or next; 2682 $map->valid or next;
2281 $map->save; 2683 $map->save;
2282 } 2684 }
2283 warn "end emergency map save\n"; 2685 warn "end emergency map save\n";
2686
2687 warn "begin emergency database checkpoint\n";
2688 BDB::db_env_txn_checkpoint $DB_ENV;
2689 warn "end emergency database checkpoint\n";
2284 }; 2690 };
2285 2691
2286 warn "leave emergency perl save\n"; 2692 warn "leave emergency perl save\n";
2287} 2693}
2288 2694
2695sub post_cleanup {
2696 my ($make_core) = @_;
2697
2698 warn Carp::longmess "post_cleanup backtrace"
2699 if $make_core;
2700}
2701
2289sub reload() { 2702sub do_reload_perl() {
2290 # can/must only be called in main 2703 # can/must only be called in main
2291 if ($Coro::current != $Coro::main) { 2704 if ($Coro::current != $Coro::main) {
2292 warn "can only reload from main coroutine\n"; 2705 warn "can only reload from main coroutine";
2293 return; 2706 return;
2294 } 2707 }
2295 2708
2296 warn "reloading..."; 2709 warn "reloading...";
2297 2710
2298 warn "freezing server"; 2711 warn "entering sync_job";
2299 my $guard = freeze_mainloop; 2712
2713 cf::sync_job {
2714 cf::write_runtime; # external watchdog should not bark
2300 cf::emergency_save; 2715 cf::emergency_save;
2716 cf::write_runtime; # external watchdog should not bark
2301 2717
2302 warn "sync database to disk"; 2718 warn "syncing database to disk";
2303 cf::db_sync; 2719 BDB::db_env_txn_checkpoint $DB_ENV;
2304 IO::AIO::flush;
2305 2720
2306 eval {
2307 # if anything goes wrong in here, we should simply crash as we already saved 2721 # if anything goes wrong in here, we should simply crash as we already saved
2308 2722
2309 warn "cancel all watchers"; 2723 warn "cancelling all WF_AUTOCANCEL watchers";
2310 for (Event::all_watchers) { 2724 for (Event::all_watchers) {
2311 $_->cancel if $_->data & WF_AUTOCANCEL; 2725 $_->cancel if $_->data & WF_AUTOCANCEL;
2312 } 2726 }
2313 2727
2728 warn "flushing outstanding aio requests";
2729 for (;;) {
2730 BDB::flush;
2731 IO::AIO::flush;
2732 Coro::cede;
2733 last unless IO::AIO::nreqs || BDB::nreqs;
2734 warn "iterate...";
2735 }
2736
2737 ++$RELOAD;
2738
2314 warn "cancel all extension coros"; 2739 warn "cancelling all extension coros";
2315 $_->cancel for values %EXT_CORO; 2740 $_->cancel for values %EXT_CORO;
2316 %EXT_CORO = (); 2741 %EXT_CORO = ();
2317 2742
2318 warn "remove commands"; 2743 warn "removing commands";
2319 %COMMAND = (); 2744 %COMMAND = ();
2320 2745
2321 warn "remove ext commands"; 2746 warn "removing ext commands";
2322 %EXTCMD = (); 2747 %EXTCMD = ();
2323 2748
2324 warn "unload/nuke all extensions"; 2749 warn "unloading/nuking all extensions";
2325 for my $pkg (@EXTS) { 2750 for my $pkg (@EXTS) {
2326 warn "... unloading $pkg"; 2751 warn "... unloading $pkg";
2327 2752
2328 if (my $cb = $pkg->can ("unload")) { 2753 if (my $cb = $pkg->can ("unload")) {
2329 eval { 2754 eval {
2334 2759
2335 warn "... nuking $pkg"; 2760 warn "... nuking $pkg";
2336 Symbol::delete_package $pkg; 2761 Symbol::delete_package $pkg;
2337 } 2762 }
2338 2763
2339 warn "unload all perl modules loaded from $LIBDIR"; 2764 warn "unloading all perl modules loaded from $LIBDIR";
2340 while (my ($k, $v) = each %INC) { 2765 while (my ($k, $v) = each %INC) {
2341 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/; 2766 next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2342 2767
2343 warn "removing <$k>"; 2768 warn "... unloading $k";
2344 delete $INC{$k}; 2769 delete $INC{$k};
2345 2770
2346 $k =~ s/\.pm$//; 2771 $k =~ s/\.pm$//;
2347 $k =~ s/\//::/g; 2772 $k =~ s/\//::/g;
2348 2773
2351 } 2776 }
2352 2777
2353 Symbol::delete_package $k; 2778 Symbol::delete_package $k;
2354 } 2779 }
2355 2780
2356 warn "get rid of safe::, as good as possible"; 2781 warn "getting rid of safe::, as good as possible";
2357 Symbol::delete_package "safe::$_" 2782 Symbol::delete_package "safe::$_"
2358 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2783 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2359 2784
2360 warn "unload cf.pm \"a bit\""; 2785 warn "unloading cf.pm \"a bit\"";
2361 delete $INC{"cf.pm"}; 2786 delete $INC{"cf.pm"};
2787 delete $INC{"cf/pod.pm"};
2362 2788
2363 # don't, removes xs symbols, too, 2789 # don't, removes xs symbols, too,
2364 # and global variables created in xs 2790 # and global variables created in xs
2365 #Symbol::delete_package __PACKAGE__; 2791 #Symbol::delete_package __PACKAGE__;
2366 2792
2793 warn "unload completed, starting to reload now";
2794
2367 warn "reloading cf.pm"; 2795 warn "reloading cf.pm";
2368 require cf; 2796 require cf;
2369 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt 2797 cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2370 2798
2371 warn "load config and database again"; 2799 warn "loading config and database again";
2372 cf::cfg_load; 2800 cf::cfg_load;
2373 cf::db_load;
2374 2801
2375 warn "load extensions"; 2802 warn "loading extensions";
2376 cf::load_extensions; 2803 cf::load_extensions;
2377 2804
2378 warn "reattach attachments to objects/players"; 2805 warn "reattaching attachments to objects/players";
2379 _global_reattach; 2806 _global_reattach; # objects, sockets
2380 warn "reattach attachments to maps"; 2807 warn "reattaching attachments to maps";
2381 reattach $_ for values %MAP; 2808 reattach $_ for values %MAP;
2382 }; 2809 warn "reattaching attachments to players";
2810 reattach $_ for values %PLAYER;
2383 2811
2384 if ($@) { 2812 warn "leaving sync_job";
2813
2814 1
2815 } or do {
2385 warn $@; 2816 warn $@;
2386 warn "error while reloading, exiting."; 2817 warn "error while reloading, exiting.";
2387 exit 1; 2818 exit 1;
2388 } 2819 };
2389 2820
2390 warn "reloaded"; 2821 warn "reloaded";
2391}; 2822};
2392 2823
2393our $RELOAD_WATCHER; # used only during reload 2824our $RELOAD_WATCHER; # used only during reload
2394 2825
2826sub reload_perl() {
2827 # doing reload synchronously and two reloads happen back-to-back,
2828 # coro crashes during coro_state_free->destroy here.
2829
2830 $RELOAD_WATCHER ||= Event->timer (
2831 reentrant => 0,
2832 after => 0,
2833 data => WF_AUTOCANCEL,
2834 cb => sub {
2835 do_reload_perl;
2836 undef $RELOAD_WATCHER;
2837 },
2838 );
2839}
2840
2395register_command "reload" => sub { 2841register_command "reload" => sub {
2396 my ($who, $arg) = @_; 2842 my ($who, $arg) = @_;
2397 2843
2398 if ($who->flag (FLAG_WIZ)) { 2844 if ($who->flag (FLAG_WIZ)) {
2399 $who->message ("reloading server."); 2845 $who->message ("reloading server.");
2400 2846 async { reload_perl };
2401 # doing reload synchronously and two reloads happen back-to-back,
2402 # coro crashes during coro_state_free->destroy here.
2403
2404 $RELOAD_WATCHER ||= Event->timer (after => 0, data => WF_AUTOCANCEL, cb => sub {
2405 reload;
2406 undef $RELOAD_WATCHER;
2407 });
2408 } 2847 }
2409}; 2848};
2410 2849
2411unshift @INC, $LIBDIR; 2850unshift @INC, $LIBDIR;
2412 2851
2852my $bug_warning = 0;
2853
2854our @WAIT_FOR_TICK;
2855our @WAIT_FOR_TICK_BEGIN;
2856
2857sub wait_for_tick {
2858 return unless $TICK_WATCHER->is_active;
2859 return if $Coro::current == $Coro::main;
2860
2861 my $signal = new Coro::Signal;
2862 push @WAIT_FOR_TICK, $signal;
2863 $signal->wait;
2864}
2865
2866sub wait_for_tick_begin {
2867 return unless $TICK_WATCHER->is_active;
2868 return if $Coro::current == $Coro::main;
2869
2870 my $signal = new Coro::Signal;
2871 push @WAIT_FOR_TICK_BEGIN, $signal;
2872 $signal->wait;
2873}
2874
2875 my $min = 1e6;#d#
2876 my $avg = 10;
2413$TICK_WATCHER = Event->timer ( 2877$TICK_WATCHER = Event->timer (
2414 reentrant => 0, 2878 reentrant => 0,
2879 parked => 1,
2415 prio => 0, 2880 prio => 0,
2416 at => $NEXT_TICK || $TICK, 2881 at => $NEXT_TICK || $TICK,
2417 data => WF_AUTOCANCEL, 2882 data => WF_AUTOCANCEL,
2418 cb => sub { 2883 cb => sub {
2884 if ($Coro::current != $Coro::main) {
2885 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2886 unless ++$bug_warning > 10;
2887 return;
2888 }
2889
2419 $NOW = Event::time; 2890 $NOW = $tick_start = Event::time;
2420 2891
2421 cf::server_tick; # one server iteration 2892 cf::server_tick; # one server iteration
2893
2894 0 && sync_job {#d#
2895 for(1..10) {
2896 my $t = Event::time;
2897 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2898 or die;
2899
2900 $map->width (50);
2901 $map->height (50);
2902 $map->alloc;
2903 $map->_load_objects ("/tmp/x.map", 1);
2904 my $t = Event::time - $t;
2905
2906 #next unless $t < 0.0013;#d#
2907 if ($t < $min) {
2908 $min = $t;
2909 }
2910 $avg = $avg * 0.99 + $t * 0.01;
2911 }
2912 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2913 exit 0;
2914 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2915 };
2916
2422 $RUNTIME += $TICK; 2917 $RUNTIME += $TICK;
2423 $NEXT_TICK += $TICK; 2918 $NEXT_TICK += $TICK;
2424 2919
2425 $WAIT_FOR_TICK->broadcast; 2920 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2426 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited; 2921 $NEXT_RUNTIME_WRITE = $NOW + 10;
2922 Coro::async_pool {
2923 write_runtime
2924 or warn "ERROR: unable to write runtime file: $!";
2925 };
2926 }
2927
2928# my $AFTER = Event::time;
2929# warn $AFTER - $NOW;#d#
2930
2931 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2932 $sig->send;
2933 }
2934 while (my $sig = shift @WAIT_FOR_TICK) {
2935 $sig->send;
2936 }
2937
2938 $NOW = Event::time;
2427 2939
2428 # if we are delayed by four ticks or more, skip them all 2940 # if we are delayed by four ticks or more, skip them all
2429 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2941 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2430 2942
2431 $TICK_WATCHER->at ($NEXT_TICK); 2943 $TICK_WATCHER->at ($NEXT_TICK);
2432 $TICK_WATCHER->start; 2944 $TICK_WATCHER->start;
2945
2946 $LOAD = ($NOW - $tick_start) / $TICK;
2947 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2948
2949 _post_tick;
2950
2951
2433 }, 2952 },
2434); 2953);
2435 2954
2955{
2956 BDB::max_poll_time $TICK * 0.1;
2957 $BDB_POLL_WATCHER = Event->io (
2958 reentrant => 0,
2959 fd => BDB::poll_fileno,
2960 poll => 'r',
2961 prio => 0,
2962 data => WF_AUTOCANCEL,
2963 cb => \&BDB::poll_cb,
2964 );
2965 BDB::min_parallel 8;
2966
2967 BDB::set_sync_prepare {
2968 my $status;
2969 my $current = $Coro::current;
2970 (
2971 sub {
2972 $status = $!;
2973 $current->ready; undef $current;
2974 },
2975 sub {
2976 Coro::schedule while defined $current;
2977 $! = $status;
2978 },
2979 )
2980 };
2981
2982 unless ($DB_ENV) {
2983 $DB_ENV = BDB::db_env_create;
2984
2985 cf::sync_job {
2986 eval {
2987 BDB::db_env_open
2988 $DB_ENV,
2989 $BDBDIR,
2990 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2991 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2992 0666;
2993
2994 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2995
2996 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2997 $DB_ENV->set_lk_detect;
2998 };
2999
3000 cf::cleanup "db_env_open(db): $@" if $@;
3001 };
3002 }
3003}
3004
3005{
3006 IO::AIO::min_parallel 8;
3007
3008 undef $Coro::AIO::WATCHER;
2436IO::AIO::max_poll_time $TICK * 0.2; 3009 IO::AIO::max_poll_time $TICK * 0.1;
2437
2438$AIO_POLL_WATCHER = Event->io ( 3010 $AIO_POLL_WATCHER = Event->io (
2439 fd => IO::AIO::poll_fileno, 3011 reentrant => 0,
2440 poll => 'r',
2441 prio => 5,
2442 data => WF_AUTOCANCEL,
2443 cb => \&IO::AIO::poll_cb,
2444);
2445
2446$WRITE_RUNTIME_WATCHER = Event->timer (
2447 data => WF_AUTOCANCEL, 3012 data => WF_AUTOCANCEL,
2448 after => 0, 3013 fd => IO::AIO::poll_fileno,
2449 interval => 10, 3014 poll => 'r',
2450 cb => sub { 3015 prio => 6,
2451 (Coro::unblock_sub { 3016 cb => \&IO::AIO::poll_cb,
2452 write_runtime 3017 );
2453 or warn "ERROR: unable to write runtime file: $!"; 3018}
3019
3020my $_log_backtrace;
3021
3022sub _log_backtrace {
3023 my ($msg, @addr) = @_;
3024
3025 $msg =~ s/\n//;
3026
3027 # limit the # of concurrent backtraces
3028 if ($_log_backtrace < 2) {
3029 ++$_log_backtrace;
3030 async {
3031 my @bt = fork_call {
3032 @addr = map { sprintf "%x", $_ } @addr;
3033 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3034 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3035 or die "addr2line: $!";
3036
3037 my @funcs;
3038 my @res = <$fh>;
3039 chomp for @res;
3040 while (@res) {
3041 my ($func, $line) = splice @res, 0, 2, ();
3042 push @funcs, "[$func] $line";
3043 }
3044
3045 @funcs
3046 };
3047
3048 LOG llevInfo, "[ABT] $msg\n";
3049 LOG llevInfo, "[ABT] $_\n" for @bt;
3050 --$_log_backtrace;
2454 })->(); 3051 };
3052 } else {
3053 LOG llevInfo, "[ABT] $msg\n";
3054 LOG llevInfo, "[ABT] [suppressed]\n";
2455 }, 3055 }
2456); 3056}
3057
3058# load additional modules
3059use cf::pod;
2457 3060
2458END { cf::emergency_save } 3061END { cf::emergency_save }
2459 3062
24601 30631
2461 3064

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines