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.217 by root, Thu Feb 15 21:07:49 2007 UTC vs.
Revision 1.269 by root, Tue May 22 21:35:26 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 $NEXT_RUNTIME_WRITE; # when should the runtime file be written 75our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
55our $NEXT_TICK; 76our $NEXT_TICK;
56our $NOW; 77our $NOW;
… …
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($) {
… …
266 287
267 Coro::guard { 288 Coro::guard {
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 }
292}
293
294sub lock_active($) {
295 my ($key) = @_;
296
297 ! ! $LOCK{$key}
271} 298}
272 299
273sub freeze_mainloop { 300sub freeze_mainloop {
274 return unless $TICK_WATCHER->is_active; 301 return unless $TICK_WATCHER->is_active;
275 302
… …
305 332
306sub sync_job(&) { 333sub sync_job(&) {
307 my ($job) = @_; 334 my ($job) = @_;
308 335
309 if ($Coro::current == $Coro::main) { 336 if ($Coro::current == $Coro::main) {
337 my $time = Event::time;
338
310 # this is the main coro, too bad, we have to block 339 # this is the main coro, too bad, we have to block
311 # till the operation succeeds, freezing the server :/ 340 # till the operation succeeds, freezing the server :/
312 341
313 # TODO: use suspend/resume instead 342 # TODO: use suspend/resume instead
314 # (but this is cancel-safe) 343 # (but this is cancel-safe)
… …
325 354
326 while ($busy) { 355 while ($busy) {
327 Coro::cede or Event::one_event; 356 Coro::cede or Event::one_event;
328 } 357 }
329 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
330 wantarray ? @res : $res[0] 366 wantarray ? @res : $res[0]
331 } else { 367 } else {
332 # we are in another coroutine, how wonderful, everything just works 368 # we are in another coroutine, how wonderful, everything just works
333 369
334 $job->() 370 $job->()
… …
354 390
355 $coro 391 $coro
356} 392}
357 393
358sub write_runtime { 394sub write_runtime {
359 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";
360 405
361 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 406 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
362 or return; 407 or return;
363 408
364 my $value = $cf::RUNTIME + 90 + 10; 409 my $value = $cf::RUNTIME + 90 + 10;
… …
370 415
371 # always fsync - this file is important 416 # always fsync - this file is important
372 aio_fsync $fh 417 aio_fsync $fh
373 and return; 418 and return;
374 419
420 # touch it again to show we are up-to-date
421 utime undef, undef, $fh;
422
375 close $fh 423 close $fh
376 or return; 424 or return;
377 425
378 aio_rename "$runtime~", $runtime 426 aio_rename "$runtime~", $runtime
379 and return; 427 and return;
380 428
429 warn "runtime file written.\n";#d#
430
381 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 });
382} 443}
383 444
384=back 445=back
385 446
386=cut 447=cut
… …
566 $registry = $CB_TYPE[$object_type] ||= []; 627 $registry = $CB_TYPE[$object_type] ||= [];
567 628
568 } elsif ($type eq "subtype") { 629 } elsif ($type eq "subtype") {
569 defined $object_type or Carp::croak "subtype specified without type"; 630 defined $object_type or Carp::croak "subtype specified without type";
570 my $object_subtype = shift @arg; 631 my $object_subtype = shift @arg;
571 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_SUBTYPES] ||= []; 632 $registry = $CB_TYPE[$object_type + $object_subtype * NUM_TYPES] ||= [];
572 633
573 } elsif ($type eq "package") { 634 } elsif ($type eq "package") {
574 my $pkg = shift @arg; 635 my $pkg = shift @arg;
575 636
576 while (my ($name, $id) = each %cb_id) { 637 while (my ($name, $id) = each %cb_id) {
… …
617 if (ref $_[0]) { 678 if (ref $_[0]) {
618 _object_attach @_; 679 _object_attach @_;
619 } else { 680 } else {
620 _attach shift->_attach_registry, @_; 681 _attach shift->_attach_registry, @_;
621 } 682 }
683 _recalc_want;
622}; 684};
623 685
624# all those should be optimised 686# all those should be optimised
625sub cf::attachable::detach { 687sub cf::attachable::detach {
626 my ($obj, $name) = @_; 688 my ($obj, $name) = @_;
… …
629 delete $obj->{_attachment}{$name}; 691 delete $obj->{_attachment}{$name};
630 reattach ($obj); 692 reattach ($obj);
631 } else { 693 } else {
632 Carp::croak "cannot, currently, detach class attachments"; 694 Carp::croak "cannot, currently, detach class attachments";
633 } 695 }
696 _recalc_want;
634}; 697};
635 698
636sub cf::attachable::attached { 699sub cf::attachable::attached {
637 my ($obj, $name) = @_; 700 my ($obj, $name) = @_;
638 701
… …
948Returns the given player object, loading it if necessary (might block). 1011Returns the given player object, loading it if necessary (might block).
949 1012
950=cut 1013=cut
951 1014
952sub playerdir($) { 1015sub playerdir($) {
953 cf::localdir 1016 "$PLAYERDIR/"
954 . "/"
955 . cf::playerdir
956 . "/"
957 . (ref $_[0] ? $_[0]->ob->name : $_[0]) 1017 . (ref $_[0] ? $_[0]->ob->name : $_[0])
958} 1018}
959 1019
960sub path($) { 1020sub path($) {
961 my $login = ref $_[0] ? $_[0]->ob->name : $_[0]; 1021 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
962 1022
963 (playerdir $login) . "/$login.pl" 1023 (playerdir $login) . "/playerdata"
964} 1024}
965 1025
966sub find_active($) { 1026sub find_active($) {
967 $cf::PLAYER{$_[0]} 1027 $cf::PLAYER{$_[0]}
968 and $cf::PLAYER{$_[0]}->active 1028 and $cf::PLAYER{$_[0]}->active
… …
981 my $login = $_[0]; 1041 my $login = $_[0];
982 1042
983 my $guard = cf::lock_acquire "user_find:$login"; 1043 my $guard = cf::lock_acquire "user_find:$login";
984 1044
985 $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
986 my $pl = load_pl path $login 1053 my $pl = load_pl path $login
987 or return; 1054 or return;
988 $cf::PLAYER{$login} = $pl 1055 $cf::PLAYER{$login} = $pl
989 } 1056 }
990 } 1057 }
… …
1027 1094
1028=cut 1095=cut
1029 1096
1030sub quit_character { 1097sub quit_character {
1031 my ($pl) = @_; 1098 my ($pl) = @_;
1099
1100 my $name = $pl->ob->name;
1032 1101
1033 $pl->{deny_save} = 1; 1102 $pl->{deny_save} = 1;
1034 $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
1035 1104
1036 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active; 1105 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
… …
1041 my $path = playerdir $pl; 1110 my $path = playerdir $pl;
1042 my $temp = "$path~$cf::RUNTIME~deleting~"; 1111 my $temp = "$path~$cf::RUNTIME~deleting~";
1043 aio_rename $path, $temp; 1112 aio_rename $path, $temp;
1044 delete $cf::PLAYER{$pl->ob->name}; 1113 delete $cf::PLAYER{$pl->ob->name};
1045 $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
1046 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;
1047} 1136}
1048 1137
1049=item cf::player::list_logins 1138=item cf::player::list_logins
1050 1139
1051Returns 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
1052while and may block, so not sync_job-capable, ever. 1141while and may block, so not sync_job-capable, ever.
1053 1142
1054=cut 1143=cut
1055 1144
1056sub list_logins { 1145sub list_logins {
1057 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir 1146 my $dirs = aio_readdir $PLAYERDIR
1058 or return []; 1147 or return [];
1059 1148
1060 my @logins; 1149 my @logins;
1061 1150
1062 for my $login (@$dirs) { 1151 for my $login (@$dirs) {
… …
1097 } 1186 }
1098 1187
1099 \@paths 1188 \@paths
1100} 1189}
1101 1190
1102=item $player->ext_reply ($msgid, $msgtype, %msg) 1191=item $player->ext_reply ($msgid, %msg)
1103 1192
1104Sends an ext reply to the player. 1193Sends an ext reply to the player.
1105 1194
1106=cut 1195=cut
1107 1196
1108sub ext_reply($$$%) { 1197sub ext_reply($$%) {
1109 my ($self, $id, %msg) = @_; 1198 my ($self, $id, %msg) = @_;
1110 1199
1111 $msg{msgid} = $id; 1200 $msg{msgid} = $id;
1112 1201
1113 $self->send ("ext " . cf::to_json \%msg); 1202 $self->send ("ext " . cf::to_json \%msg);
1114} 1203}
1115 1204
1116package 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}
1117 1245
1118=back 1246=back
1119
1120 1247
1121=head3 cf::map 1248=head3 cf::map
1122 1249
1123=over 4 1250=over 4
1124 1251
… …
1262 1389
1263# the original (read-only) location 1390# the original (read-only) location
1264sub load_path { 1391sub load_path {
1265 my ($self) = @_; 1392 my ($self) = @_;
1266 1393
1267 sprintf "%s/%s/%s.map", cf::datadir, cf::mapdir, $self->{path} 1394 "$MAPDIR/$self->{path}.map"
1268} 1395}
1269 1396
1270# the temporary/swap location 1397# the temporary/swap location
1271sub save_path { 1398sub save_path {
1272 my ($self) = @_; 1399 my ($self) = @_;
1273 1400
1274 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1401 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1275 sprintf "%s/%s/%s.map", cf::localdir, cf::tmpdir, $path 1402 "$TMPDIR/$path.map"
1276} 1403}
1277 1404
1278# the unique path, undef == no special unique path 1405# the unique path, undef == no special unique path
1279sub uniq_path { 1406sub uniq_path {
1280 my ($self) = @_; 1407 my ($self) = @_;
1281 1408
1282 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g; 1409 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
1283 sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path 1410 "$UNIQUEDIR/$path"
1284} 1411}
1285 1412
1286# and all this just because we cannot iterate over 1413# and all this just because we cannot iterate over
1287# all maps in C++... 1414# all maps in C++...
1288sub change_all_map_light { 1415sub change_all_map_light {
… …
1355 $self->load_header_orig 1482 $self->load_header_orig
1356 or return; 1483 or return;
1357 $self->prepare_orig; 1484 $self->prepare_orig;
1358 } 1485 }
1359 1486
1487 $self->default_region (cf::region::find_by_path $self->{path})
1488 unless $self->default_region;
1489
1360 1 1490 1
1361} 1491}
1362 1492
1363sub find; 1493sub find;
1364sub find { 1494sub find {
… …
1397 my ($self) = @_; 1527 my ($self) = @_;
1398 1528
1399 local $self->{deny_reset} = 1; # loading can take a long time 1529 local $self->{deny_reset} = 1; # loading can take a long time
1400 1530
1401 my $path = $self->{path}; 1531 my $path = $self->{path};
1532
1533 {
1402 my $guard = cf::lock_acquire "map_load:$path"; 1534 my $guard = cf::lock_acquire "map_load:$path";
1403 1535
1404 return if $self->in_memory != cf::MAP_SWAPPED; 1536 return if $self->in_memory != cf::MAP_SWAPPED;
1405 1537
1406 $self->in_memory (cf::MAP_LOADING); 1538 $self->in_memory (cf::MAP_LOADING);
1407 1539
1408 $self->alloc; 1540 $self->alloc;
1409 1541
1410 $self->pre_load; 1542 $self->pre_load;
1411
1412 $self->_load_objects ($self->{load_path}, 1)
1413 or return;
1414
1415 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1416 if delete $self->{load_original};
1417
1418 if (my $uniq = $self->uniq_path) {
1419 utf8::encode $uniq;
1420 if (aio_open $uniq, O_RDONLY, 0) {
1421 $self->clear_unique_items;
1422 $self->_load_objects ($uniq, 0);
1423 }
1424 }
1425
1426 Coro::cede;
1427
1428 # now do the right thing for maps
1429 $self->link_multipart_objects;
1430
1431 unless ($self->{deny_activate}) {
1432 $self->decay_objects;
1433 $self->fix_auto_apply;
1434 $self->update_buttons;
1435 Coro::cede; 1543 Coro::cede;
1436 $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;
1437 $self->difficulty ($self->estimate_difficulty) 1562 $self->difficulty ($self->estimate_difficulty)
1438 unless $self->difficulty; 1563 unless $self->difficulty;
1439 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;
1440 $self->activate; 1573 $self->activate;
1574 }
1575
1576 $self->in_memory (cf::MAP_IN_MEMORY);
1441 } 1577 }
1442 1578
1443 $self->post_load; 1579 $self->post_load;
1444
1445 $self->in_memory (cf::MAP_IN_MEMORY);
1446} 1580}
1447 1581
1448sub customise_for { 1582sub customise_for {
1449 my ($self, $ob) = @_; 1583 my ($self, $ob) = @_;
1450 1584
… …
1641instantiated unique items. May block. 1775instantiated unique items. May block.
1642 1776
1643=cut 1777=cut
1644 1778
1645sub unique_maps() { 1779sub unique_maps() {
1646 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir 1780 my $files = aio_readdir $UNIQUEDIR
1647 or return; 1781 or return;
1648 1782
1649 my @paths; 1783 my @paths;
1650 1784
1651 for (@$files) { 1785 for (@$files) {
… …
1841 })->prio (2); 1975 })->prio (2);
1842 } 1976 }
1843 }, 1977 },
1844); 1978);
1845 1979
1846=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.
1847 1986
1848=cut 1987=cut
1849 1988
1850sub cf::object::player::goto { 1989sub cf::object::player::goto {
1851 my ($self, $path, $x, $y) = @_; 1990 my ($self, $path, $x, $y, $check) = @_;
1852 1991
1853 $self->enter_link; 1992 $self->enter_link;
1854 1993
1855 (async { 1994 (async {
1856 my $map = eval { 1995 my $map = eval {
1857 my $map = cf::map::find $path; 1996 my $map = cf::map::find $path;
1997
1998 if ($map) {
1858 $map = $map->customise_for ($self) if $map; 1999 $map = $map->customise_for ($self);
2000 $map = $check->($map) if $check && $map;
2001 } else {
2002 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
2003 }
2004
1859 $map 2005 $map
2006 };
2007
2008 if ($@) {
2009 $self->message ("Something went wrong within the server, please report this incident!", cf::NDI_UNIQUE | cf::NDI_RED);
2010 LOG llevError | logBacktrace, Carp::longmess $@;
1860 } or 2011 }
1861 $self->message ("The exit to '$path' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1862 2012
1863 $self->leave_link ($map, $x, $y); 2013 $self->leave_link ($map, $x, $y);
1864 })->prio (1); 2014 })->prio (1);
1865} 2015}
1866 2016
… …
1907 2057
1908 $rmp->{random_seed} ||= $exit->random_seed; 2058 $rmp->{random_seed} ||= $exit->random_seed;
1909 2059
1910 my $data = cf::to_json $rmp; 2060 my $data = cf::to_json $rmp;
1911 my $md5 = Digest::MD5::md5_hex $data; 2061 my $md5 = Digest::MD5::md5_hex $data;
1912 my $meta = "$cf::RANDOM_MAPS/$md5.meta"; 2062 my $meta = "$RANDOMDIR/$md5.meta";
1913 2063
1914 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) { 2064 if (my $fh = aio_open "$meta~", O_WRONLY | O_CREAT, 0666) {
1915 aio_write $fh, 0, (length $data), $data, 0; 2065 aio_write $fh, 0, (length $data), $data, 0;
1916 undef $fh; 2066 undef $fh;
1917 aio_rename "$meta~", $meta; 2067 aio_rename "$meta~", $meta;
… …
1926 2076
1927 return unless $self->type == cf::PLAYER; 2077 return unless $self->type == cf::PLAYER;
1928 2078
1929 if ($exit->slaying eq "/!") { 2079 if ($exit->slaying eq "/!") {
1930 #TODO: this should de-fi-ni-te-ly not be a sync-job 2080 #TODO: this should de-fi-ni-te-ly not be a sync-job
2081 # the problem is that $exit might not survive long enough
2082 # so it needs to be done right now, right here
1931 cf::sync_job { prepare_random_map $exit }; 2083 cf::sync_job { prepare_random_map $exit };
1932 } 2084 }
1933 2085
1934 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path; 2086 my $slaying = cf::map::normalise $exit->slaying, $exit->map && $exit->map->path;
1935 my $hp = $exit->stats->hp; 2087 my $hp = $exit->stats->hp;
… …
1943 $self->goto ($slaying, $hp, $sp); 2095 $self->goto ($slaying, $hp, $sp);
1944 2096
1945 1; 2097 1;
1946 }) { 2098 }) {
1947 $self->message ("Something went wrong deep within the crossfire server. " 2099 $self->message ("Something went wrong deep within the crossfire server. "
1948 . "I'll try to bring you back to the map you were before. " 2100 . "I'll try to bring you back to the map you were before. "
1949 . "Please report this to the dungeon master!", 2101 . "Please report this to the dungeon master!",
1950 cf::NDI_UNIQUE | cf::NDI_RED); 2102 cf::NDI_UNIQUE | cf::NDI_RED);
1951 2103
1952 warn "ERROR in enter_exit: $@"; 2104 warn "ERROR in enter_exit: $@";
1953 $self->leave_link; 2105 $self->leave_link;
1954 } 2106 }
1955 })->prio (1); 2107 })->prio (1);
… …
1968 2120
1969sub cf::client::send_drawinfo { 2121sub cf::client::send_drawinfo {
1970 my ($self, $text, $flags) = @_; 2122 my ($self, $text, $flags) = @_;
1971 2123
1972 utf8::encode $text; 2124 utf8::encode $text;
1973 $self->send_packet (sprintf "drawinfo %d %s", $flags, $text); 2125 $self->send_packet (sprintf "drawinfo %d %s", $flags || cf::NDI_BLACK, $text);
1974} 2126}
1975 2127
2128=item $client->ext_event ($type, %msg)
2129
2130Sends an exti event to the client.
2131
2132=cut
2133
2134sub cf::client::ext_event($$%) {
2135 my ($self, $type, %msg) = @_;
2136
2137 $msg{msgtype} = "event_$type";
2138 $self->send_packet ("ext " . cf::to_json \%msg);
2139}
1976 2140
1977=item $success = $client->query ($flags, "text", \&cb) 2141=item $success = $client->query ($flags, "text", \&cb)
1978 2142
1979Queues a query to the client, calling the given callback with 2143Queues a query to the client, calling the given callback with
1980the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>, 2144the reply text on a reply. flags can be C<cf::CS_QUERY_YESNO>,
… …
2077 2241
2078# here we export the classes and methods available to script code 2242# here we export the classes and methods available to script code
2079 2243
2080=pod 2244=pod
2081 2245
2082The following fucntions and emthods are available within a safe environment: 2246The following functions and methods are available within a safe environment:
2083 2247
2084 cf::object contr pay_amount pay_player map 2248 cf::object contr pay_amount pay_player map
2085 cf::object::player player 2249 cf::object::player player
2086 cf::player peaceful 2250 cf::player peaceful
2087 cf::map trigger 2251 cf::map trigger
… …
2172############################################################################# 2336#############################################################################
2173 2337
2174=head2 EXTENSION DATABASE SUPPORT 2338=head2 EXTENSION DATABASE SUPPORT
2175 2339
2176Crossfire maintains a very simple database for extension use. It can 2340Crossfire maintains a very simple database for extension use. It can
2177currently store anything that can be serialised using Storable, which 2341currently store binary data only (use Compress::LZF::sfreeze_cr/sthaw to
2178excludes objects. 2342convert to/from binary).
2179 2343
2180The parameter C<$family> should best start with the name of the extension 2344The parameter C<$family> should best start with the name of the extension
2181using it, it should be unique. 2345using it, it should be unique.
2182 2346
2183=over 4 2347=over 4
… …
2206 BDB::CREATE | BDB::AUTO_COMMIT, 0666; 2370 BDB::CREATE | BDB::AUTO_COMMIT, 0666;
2207 cf::cleanup "db_open(db): $!" if $!; 2371 cf::cleanup "db_open(db): $!" if $!;
2208 }; 2372 };
2209 cf::cleanup "db_open(db): $@" if $@; 2373 cf::cleanup "db_open(db): $@" if $@;
2210 }; 2374 };
2211
2212 my $path = cf::localdir . "/database.pst";
2213 if (stat $path) {
2214 cf::sync_job {
2215 my $pst = Storable::retrieve $path;
2216
2217 cf::db_put (board => data => $pst->{board});
2218 cf::db_put (guildrules => data => $pst->{guildrules});
2219 cf::db_put (rent => balance => $pst->{rent}{balance});
2220 BDB::db_env_txn_checkpoint $DB_ENV;
2221
2222 unlink $path;
2223 };
2224 }
2225 } 2375 }
2226} 2376}
2227 2377
2228sub db_get($$) { 2378sub db_get($$) {
2229 my $key = "$_[0]/$_[1]"; 2379 my $key = "$_[0]/$_[1]";
2230 2380
2231 cf::sync_job { 2381 cf::sync_job {
2232 BDB::db_get $DB, undef, $key, my $data; 2382 BDB::db_get $DB, undef, $key, my $data;
2233 2383
2234 $! ? () 2384 $! ? ()
2235 : Compress::LZF::sthaw $data 2385 : $data
2236 } 2386 }
2237} 2387}
2238 2388
2239sub db_put($$$) { 2389sub db_put($$$) {
2240 BDB::dbreq_pri 4; 2390 BDB::dbreq_pri 4;
2241 BDB::db_put $DB, undef, "$_[0]/$_[1]", Compress::LZF::sfreeze_cr $_[2], 0, sub { }; 2391 BDB::db_put $DB, undef, "$_[0]/$_[1]", $_[2], 0, sub { };
2242} 2392}
2393
2394=item cf::cache $id => [$paths...], $processversion => $process
2395
2396Generic caching function that returns the value of the resource $id,
2397caching and regenerating as required.
2398
2399This function can block.
2400
2401=cut
2402
2403sub cache {
2404 my ($id, $src, $processversion, $process) = @_;
2405
2406 my $meta =
2407 join "\x00",
2408 $processversion,
2409 map {
2410 aio_stat $_
2411 and Carp::croak "$_: $!";
2412
2413 ($_, (stat _)[7,9])
2414 } @$src;
2415
2416 my $dbmeta = db_get cache => "$id/meta";
2417 if ($dbmeta ne $meta) {
2418 # changed, we may need to process
2419
2420 my @data;
2421 my $md5;
2422
2423 for (0 .. $#$src) {
2424 0 <= aio_load $src->[$_], $data[$_]
2425 or Carp::croak "$src->[$_]: $!";
2426 }
2427
2428 # if processing is expensive, check
2429 # checksum first
2430 if (1) {
2431 $md5 =
2432 join "\x00",
2433 $processversion,
2434 map {
2435 Coro::cede;
2436 ($src->[$_], Digest::MD5::md5_hex $data[$_])
2437 } 0.. $#$src;
2438
2439
2440 my $dbmd5 = db_get cache => "$id/md5";
2441 if ($dbmd5 eq $md5) {
2442 db_put cache => "$id/meta", $meta;
2443
2444 return db_get cache => "$id/data";
2445 }
2446 }
2447
2448 my $t1 = Time::HiRes::time;
2449 my $data = $process->(\@data);
2450 my $t2 = Time::HiRes::time;
2451
2452 warn "cache: '$id' processed in ", $t2 - $t1, "s\n";
2453
2454 db_put cache => "$id/data", $data;
2455 db_put cache => "$id/md5" , $md5;
2456 db_put cache => "$id/meta", $meta;
2457
2458 return $data;
2459 }
2460
2461 db_get cache => "$id/data"
2462}
2463
2464=item fork_call { }, $args
2465
2466Executes the given code block with the given arguments in a seperate
2467process, returning the results. Everything must be serialisable with
2468Coro::Storable. May, of course, block. Note that the executed sub may
2469never block itself or use any form of Event handling.
2470
2471=cut
2472
2473sub fork_call(&@) {
2474 my ($cb, @args) = @_;
2475
2476# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC
2477# or die "socketpair: $!";
2478 pipe my $fh1, my $fh2
2479 or die "pipe: $!";
2480
2481 if (my $pid = fork) {
2482 close $fh2;
2483
2484 my $res = (Coro::Handle::unblock $fh1)->readline (undef);
2485 $res = Coro::Storable::thaw $res;
2486
2487 waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
2488
2489 die $$res unless "ARRAY" eq ref $res;
2490
2491 return wantarray ? @$res : $res->[-1];
2492 } else {
2493 reset_signals;
2494 local $SIG{__WARN__};
2495 local $SIG{__DIE__};
2496 eval {
2497 close $fh1;
2498
2499 my @res = eval { $cb->(@args) };
2500 syswrite $fh2, Coro::Storable::freeze +($@ ? \"$@" : \@res);
2501 };
2502
2503 warn $@ if $@;
2504 _exit 0;
2505 }
2506}
2507
2508
2243 2509
2244############################################################################# 2510#############################################################################
2245# the server's init and main functions 2511# the server's init and main functions
2246 2512
2247sub init_resources { 2513sub load_facedata($) {
2248 load_resource_file sprintf "%s/%s/regions", cf::datadir, cf::mapdir 2514 my ($path) = @_;
2515
2516 warn "loading facedata from $path\n";
2517
2518 my $facedata;
2519 0 < aio_load $path, $facedata
2520 or die "$path: $!";
2521
2522 $facedata = Coro::Storable::thaw $facedata;
2523
2524 $facedata->{version} == 2
2525 or cf::cleanup "$path: version mismatch, cannot proceed.";
2526
2527 {
2528 my $faces = $facedata->{faceinfo};
2529
2530 while (my ($face, $info) = each %$faces) {
2531 my $idx = (cf::face::find $face) || cf::face::alloc $face;
2532 cf::face::set $idx, $info->{visibility}, $info->{magicmap};
2533 cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};
2534 cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};
2535 Coro::cede;
2536 }
2537
2538 while (my ($face, $info) = each %$faces) {
2539 next unless $info->{smooth};
2540 my $idx = cf::face::find $face
2541 or next;
2542 if (my $smooth = cf::face::find $info->{smooth}) {
2543 cf::face::set_smooth $idx, $smooth, $info->{smoothlevel};
2544 } else {
2545 warn "smooth face '$info->{smooth}' not found for face '$face'";
2546 }
2547 Coro::cede;
2548 }
2549 }
2550
2551 {
2552 my $anims = $facedata->{animinfo};
2553
2554 while (my ($anim, $info) = each %$anims) {
2555 cf::anim::set $anim, $info->{frames}, $info->{facings};
2556 Coro::cede;
2557 }
2558
2559 cf::anim::invalidate_all; # d'oh
2560 }
2561
2562 1
2563}
2564
2565sub reload_regions {
2566 load_resource_file "$MAPDIR/regions"
2249 or die "unable to load regions file\n";#d# 2567 or die "unable to load regions file\n";
2568}
2569
2570sub reload_facedata {
2571 load_facedata "$DATADIR/facedata"
2572 or die "unable to load facedata\n";
2573}
2574
2575sub reload_archetypes {
2576 load_resource_file "$DATADIR/archetypes"
2577 or die "unable to load archetypes\n";
2578}
2579
2580sub reload_treasures {
2581 load_resource_file "$DATADIR/treasures"
2582 or die "unable to load treasurelists\n";
2583}
2584
2585sub reload_resources {
2586 warn "reloading resource files...\n";
2587
2588 reload_regions;
2589 reload_facedata;
2590 reload_archetypes;
2591 reload_treasures;
2592
2593 warn "finished reloading resource files\n";
2594}
2595
2596sub init {
2597 reload_resources;
2250} 2598}
2251 2599
2252sub cfg_load { 2600sub cfg_load {
2253 open my $fh, "<:utf8", cf::confdir . "/config" 2601 open my $fh, "<:utf8", "$CONFDIR/config"
2254 or return; 2602 or return;
2255 2603
2256 local $/; 2604 local $/;
2257 *CFG = YAML::Syck::Load <$fh>; 2605 *CFG = YAML::Syck::Load <$fh>;
2258 2606
… …
2266 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()" 2614 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2267 and die "WARNING: m(un)lockall failed: $!\n"; 2615 and die "WARNING: m(un)lockall failed: $!\n";
2268 }; 2616 };
2269 warn $@ if $@; 2617 warn $@ if $@;
2270 } 2618 }
2271}
2272
2273sub init {
2274 init_resources;
2275} 2619}
2276 2620
2277sub main { 2621sub main {
2278 # we must not ever block the main coroutine 2622 # we must not ever block the main coroutine
2279 local $Coro::idle = sub { 2623 local $Coro::idle = sub {
… …
2347 2691
2348 warn Carp::longmess "post_cleanup backtrace" 2692 warn Carp::longmess "post_cleanup backtrace"
2349 if $make_core; 2693 if $make_core;
2350} 2694}
2351 2695
2352sub reload() { 2696sub do_reload_perl() {
2353 # can/must only be called in main 2697 # can/must only be called in main
2354 if ($Coro::current != $Coro::main) { 2698 if ($Coro::current != $Coro::main) {
2355 warn "can only reload from main coroutine"; 2699 warn "can only reload from main coroutine";
2356 return; 2700 return;
2357 } 2701 }
… …
2382 Coro::cede; 2726 Coro::cede;
2383 last unless IO::AIO::nreqs || BDB::nreqs; 2727 last unless IO::AIO::nreqs || BDB::nreqs;
2384 warn "iterate..."; 2728 warn "iterate...";
2385 } 2729 }
2386 2730
2731 ++$RELOAD;
2732
2387 warn "cancelling all extension coros"; 2733 warn "cancelling all extension coros";
2388 $_->cancel for values %EXT_CORO; 2734 $_->cancel for values %EXT_CORO;
2389 %EXT_CORO = (); 2735 %EXT_CORO = ();
2390 2736
2391 warn "removing commands"; 2737 warn "removing commands";
… …
2430 Symbol::delete_package "safe::$_" 2776 Symbol::delete_package "safe::$_"
2431 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region); 2777 for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2432 2778
2433 warn "unloading cf.pm \"a bit\""; 2779 warn "unloading cf.pm \"a bit\"";
2434 delete $INC{"cf.pm"}; 2780 delete $INC{"cf.pm"};
2781 delete $INC{"cf/pod.pm"};
2435 2782
2436 # don't, removes xs symbols, too, 2783 # don't, removes xs symbols, too,
2437 # and global variables created in xs 2784 # and global variables created in xs
2438 #Symbol::delete_package __PACKAGE__; 2785 #Symbol::delete_package __PACKAGE__;
2439 2786
… …
2448 2795
2449 warn "loading extensions"; 2796 warn "loading extensions";
2450 cf::load_extensions; 2797 cf::load_extensions;
2451 2798
2452 warn "reattaching attachments to objects/players"; 2799 warn "reattaching attachments to objects/players";
2453 _global_reattach; 2800 _global_reattach; # objects, sockets
2454 warn "reattaching attachments to maps"; 2801 warn "reattaching attachments to maps";
2455 reattach $_ for values %MAP; 2802 reattach $_ for values %MAP;
2456 2803 warn "reattaching attachments to players";
2457 warn "loading reloadable resources"; 2804 reattach $_ for values %PLAYER;
2458 init_resources;
2459 2805
2460 warn "leaving sync_job"; 2806 warn "leaving sync_job";
2461 2807
2462 1 2808 1
2463 } or do { 2809 } or do {
… …
2469 warn "reloaded"; 2815 warn "reloaded";
2470}; 2816};
2471 2817
2472our $RELOAD_WATCHER; # used only during reload 2818our $RELOAD_WATCHER; # used only during reload
2473 2819
2820sub reload_perl() {
2821 # doing reload synchronously and two reloads happen back-to-back,
2822 # coro crashes during coro_state_free->destroy here.
2823
2824 $RELOAD_WATCHER ||= Event->timer (
2825 reentrant => 0,
2826 after => 0,
2827 data => WF_AUTOCANCEL,
2828 cb => sub {
2829 do_reload_perl;
2830 undef $RELOAD_WATCHER;
2831 },
2832 );
2833}
2834
2474register_command "reload" => sub { 2835register_command "reload" => sub {
2475 my ($who, $arg) = @_; 2836 my ($who, $arg) = @_;
2476 2837
2477 if ($who->flag (FLAG_WIZ)) { 2838 if ($who->flag (FLAG_WIZ)) {
2478 $who->message ("reloading server."); 2839 $who->message ("reloading server.");
2479 2840 async { reload_perl };
2480 # doing reload synchronously and two reloads happen back-to-back,
2481 # coro crashes during coro_state_free->destroy here.
2482
2483 $RELOAD_WATCHER ||= Event->timer (
2484 reentrant => 0,
2485 after => 0,
2486 data => WF_AUTOCANCEL,
2487 cb => sub {
2488 reload;
2489 undef $RELOAD_WATCHER;
2490 },
2491 );
2492 } 2841 }
2493}; 2842};
2494 2843
2495unshift @INC, $LIBDIR; 2844unshift @INC, $LIBDIR;
2496 2845
2497my $bug_warning = 0; 2846my $bug_warning = 0;
2498 2847
2848our @WAIT_FOR_TICK;
2849our @WAIT_FOR_TICK_BEGIN;
2850
2851sub wait_for_tick {
2852 return unless $TICK_WATCHER->is_active;
2853 return if $Coro::current == $Coro::main;
2854
2855 my $signal = new Coro::Signal;
2856 push @WAIT_FOR_TICK, $signal;
2857 $signal->wait;
2858}
2859
2860sub wait_for_tick_begin {
2861 return unless $TICK_WATCHER->is_active;
2862 return if $Coro::current == $Coro::main;
2863
2864 my $signal = new Coro::Signal;
2865 push @WAIT_FOR_TICK_BEGIN, $signal;
2866 $signal->wait;
2867}
2868
2869 my $min = 1e6;#d#
2870 my $avg = 10;
2499$TICK_WATCHER = Event->timer ( 2871$TICK_WATCHER = Event->timer (
2500 reentrant => 0, 2872 reentrant => 0,
2501 parked => 1, 2873 parked => 1,
2502 prio => 0, 2874 prio => 0,
2503 at => $NEXT_TICK || $TICK, 2875 at => $NEXT_TICK || $TICK,
… …
2507 Carp::cluck "major BUG: server tick called outside of main coro, skipping it" 2879 Carp::cluck "major BUG: server tick called outside of main coro, skipping it"
2508 unless ++$bug_warning > 10; 2880 unless ++$bug_warning > 10;
2509 return; 2881 return;
2510 } 2882 }
2511 2883
2512 $NOW = Event::time; 2884 $NOW = $tick_start = Event::time;
2513 2885
2514 cf::server_tick; # one server iteration 2886 cf::server_tick; # one server iteration
2887
2888 0 && sync_job {#d#
2889 for(1..10) {
2890 my $t = Event::time;
2891 my $map = my $map = new_from_path cf::map "/tmp/x.map"
2892 or die;
2893
2894 $map->width (50);
2895 $map->height (50);
2896 $map->alloc;
2897 $map->_load_objects ("/tmp/x.map", 1);
2898 my $t = Event::time - $t;
2899
2900 #next unless $t < 0.0013;#d#
2901 if ($t < $min) {
2902 $min = $t;
2903 }
2904 $avg = $avg * 0.99 + $t * 0.01;
2905 }
2906 warn "XXXXXXXXXXXXXXXXXX min $min avg $avg\n";#d#
2907 exit 0;
2908 # 2007-05-22 02:33:04.569 min 0.00112509727478027 avg 0.0012259249572477
2909 };
2910
2515 $RUNTIME += $TICK; 2911 $RUNTIME += $TICK;
2516 $NEXT_TICK += $TICK; 2912 $NEXT_TICK += $TICK;
2517 2913
2518 if ($NOW >= $NEXT_RUNTIME_WRITE) { 2914 if ($NOW >= $NEXT_RUNTIME_WRITE) {
2519 $NEXT_RUNTIME_WRITE = $NOW + 10; 2915 $NEXT_RUNTIME_WRITE = $NOW + 10;
… …
2521 write_runtime 2917 write_runtime
2522 or warn "ERROR: unable to write runtime file: $!"; 2918 or warn "ERROR: unable to write runtime file: $!";
2523 }; 2919 };
2524 } 2920 }
2525 2921
2526
2527 $WAIT_FOR_TICK->broadcast;
2528 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2529
2530# my $AFTER = Event::time; 2922# my $AFTER = Event::time;
2531# warn $AFTER - $NOW;#d# 2923# warn $AFTER - $NOW;#d#
2532 2924
2925 if (my $sig = shift @WAIT_FOR_TICK_BEGIN) {
2926 $sig->send;
2927 }
2928 while (my $sig = shift @WAIT_FOR_TICK) {
2929 $sig->send;
2930 }
2931
2932 $NOW = Event::time;
2933
2533 # if we are delayed by four ticks or more, skip them all 2934 # if we are delayed by four ticks or more, skip them all
2534 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2935 $NEXT_TICK = $NOW if $NOW >= $NEXT_TICK + $TICK * 4;
2535 2936
2536 $TICK_WATCHER->at ($NEXT_TICK); 2937 $TICK_WATCHER->at ($NEXT_TICK);
2537 $TICK_WATCHER->start; 2938 $TICK_WATCHER->start;
2939
2940 $LOAD = ($NOW - $tick_start) / $TICK;
2941 $LOADAVG = $LOADAVG * 0.75 + $LOAD * 0.25;
2942
2943 _post_tick;
2944
2945
2538 }, 2946 },
2539); 2947);
2540 2948
2541{ 2949{
2542 BDB::max_poll_time $TICK * 0.1; 2950 BDB::max_poll_time $TICK * 0.1;
… …
2570 2978
2571 cf::sync_job { 2979 cf::sync_job {
2572 eval { 2980 eval {
2573 BDB::db_env_open 2981 BDB::db_env_open
2574 $DB_ENV, 2982 $DB_ENV,
2575 $BDB_ENV_DIR, 2983 $BDBDIR,
2576 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN 2984 BDB::INIT_LOCK | BDB::INIT_LOG | BDB::INIT_MPOOL | BDB::INIT_TXN
2577 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE, 2985 | BDB::RECOVER | BDB::REGISTER | BDB::USE_ENVIRON | BDB::CREATE,
2578 0666; 2986 0666;
2579 2987
2580 cf::cleanup "db_env_open($BDB_ENV_DIR): $!" if $!; 2988 cf::cleanup "db_env_open($BDBDIR): $!" if $!;
2581 2989
2582 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1); 2990 $DB_ENV->set_flags (BDB::AUTO_COMMIT | BDB::REGION_INIT | BDB::TXN_NOSYNC, 1);
2583 $DB_ENV->set_lk_detect; 2991 $DB_ENV->set_lk_detect;
2584 }; 2992 };
2585 2993
… …
2601 prio => 6, 3009 prio => 6,
2602 cb => \&IO::AIO::poll_cb, 3010 cb => \&IO::AIO::poll_cb,
2603 ); 3011 );
2604} 3012}
2605 3013
3014my $_log_backtrace;
3015
3016sub _log_backtrace {
3017 my ($msg, @addr) = @_;
3018
3019 $msg =~ s/\n//;
3020
3021 # limit the # of concurrent backtraces
3022 if ($_log_backtrace < 2) {
3023 ++$_log_backtrace;
3024 async {
3025 my @bt = fork_call {
3026 @addr = map { sprintf "%x", $_ } @addr;
3027 my $self = (-f "/proc/$$/exe") ? "/proc/$$/exe" : $^X;
3028 open my $fh, "exec addr2line -C -f -i -e \Q$self\E @addr 2>&1 |"
3029 or die "addr2line: $!";
3030
3031 my @funcs;
3032 my @res = <$fh>;
3033 chomp for @res;
3034 while (@res) {
3035 my ($func, $line) = splice @res, 0, 2, ();
3036 push @funcs, "[$func] $line";
3037 }
3038
3039 @funcs
3040 };
3041
3042 LOG llevInfo, "[ABT] $msg\n";
3043 LOG llevInfo, "[ABT] $_\n" for @bt;
3044 --$_log_backtrace;
3045 };
3046 } else {
3047 LOG llevInfo, "[ABT] $msg\n";
3048 LOG llevInfo, "[ABT] [suppressed]\n";
3049 }
3050}
3051
3052# load additional modules
3053use cf::pod;
3054
2606END { cf::emergency_save } 3055END { cf::emergency_save }
2607 3056
26081 30571
2609 3058

Diff Legend

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