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.126 by root, Tue Jan 2 23:12:47 2007 UTC vs.
Revision 1.158 by root, Wed Jan 10 19:52:43 2007 UTC

8use Storable; 8use Storable;
9use Opcode; 9use Opcode;
10use Safe; 10use Safe;
11use Safe::Hole; 11use Safe::Hole;
12 12
13use Coro 3.3; 13use Coro 3.3 ();
14use Coro::Event; 14use Coro::Event;
15use Coro::Timer; 15use Coro::Timer;
16use Coro::Signal; 16use Coro::Signal;
17use Coro::Semaphore; 17use Coro::Semaphore;
18use Coro::AIO; 18use Coro::AIO;
19 19
20use Data::Dumper;
20use Digest::MD5; 21use Digest::MD5;
21use Fcntl; 22use Fcntl;
22use IO::AIO 2.31 (); 23use IO::AIO 2.32 ();
23use YAML::Syck (); 24use YAML::Syck ();
24use Time::HiRes; 25use Time::HiRes;
25 26
26use Event; $Event::Eval = 1; # no idea why this is required, but it is 27use Event; $Event::Eval = 1; # no idea why this is required, but it is
27 28
29sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
30
28# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode? 31# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29$YAML::Syck::ImplicitUnicode = 1; 32$YAML::Syck::ImplicitUnicode = 1;
30 33
31$Coro::main->prio (2); # run main coroutine ("the server") with very high priority 34$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32
33sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34 35
35our %COMMAND = (); 36our %COMMAND = ();
36our %COMMAND_TIME = (); 37our %COMMAND_TIME = ();
37our %EXTCMD = (); 38our %EXTCMD = ();
38 39
47our %CFG; 48our %CFG;
48 49
49our $UPTIME; $UPTIME ||= time; 50our $UPTIME; $UPTIME ||= time;
50our $RUNTIME; 51our $RUNTIME;
51 52
53our %PLAYER; # all users
52our %MAP; # all maps 54our %MAP; # all maps
53our $LINK_MAP; # the special {link} map 55our $LINK_MAP; # the special {link} map
54our $FREEZE;
55our $RANDOM_MAPS = cf::localdir . "/random"; 56our $RANDOM_MAPS = cf::localdir . "/random";
56our %EXT_CORO; 57our %EXT_CORO; # coroutines bound to extensions
58
59our $WAIT_FOR_TICK; $WAIT_FOR_TICK ||= new Coro::Signal;
60our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE ||= new Coro::Signal;
57 61
58binmode STDOUT; 62binmode STDOUT;
59binmode STDERR; 63binmode STDERR;
60 64
61# read virtual server time, if available 65# read virtual server time, if available
71mkdir cf::localdir . "/" . cf::uniquedir; 75mkdir cf::localdir . "/" . cf::uniquedir;
72mkdir $RANDOM_MAPS; 76mkdir $RANDOM_MAPS;
73 77
74# a special map that is always available 78# a special map that is always available
75our $LINK_MAP; 79our $LINK_MAP;
76 80our $EMERGENCY_POSITION;
77our $EMERGENCY_POSITION = $cf::CFG{emergency_position} || ["/world/world_105_115", 5, 37];
78 81
79############################################################################# 82#############################################################################
80 83
81=head2 GLOBAL VARIABLES 84=head2 GLOBAL VARIABLES
82 85
106 109
107=item %cf::CFG 110=item %cf::CFG
108 111
109Configuration for the server, loaded from C</etc/crossfire/config>, or 112Configuration for the server, loaded from C</etc/crossfire/config>, or
110from wherever your confdir points to. 113from wherever your confdir points to.
114
115=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
116
117These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
118or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
119processing has been done. Call C<< ->wait >> on them to maximise the
120window of cpu time available, or simply to synchronise to the server tick.
111 121
112=back 122=back
113 123
114=cut 124=cut
115 125
119 utf8::encode $msg; 129 utf8::encode $msg;
120 130
121 $msg .= "\n" 131 $msg .= "\n"
122 unless $msg =~ /\n$/; 132 unless $msg =~ /\n$/;
123 133
124 LOG llevError, "cfperl: $msg"; 134 LOG llevError, $msg;
125 }; 135 };
126} 136}
127 137
128@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable'; 138@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
129@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable'; 139@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
155 165
156=head2 UTILITY FUNCTIONS 166=head2 UTILITY FUNCTIONS
157 167
158=over 4 168=over 4
159 169
170=item dumpval $ref
171
160=cut 172=cut
173
174sub dumpval {
175 eval {
176 local $SIG{__DIE__};
177 my $d;
178 if (1) {
179 $d = new Data::Dumper([$_[0]], ["*var"]);
180 $d->Terse(1);
181 $d->Indent(2);
182 $d->Quotekeys(0);
183 $d->Useqq(1);
184 #$d->Bless(...);
185 $d->Seen($_[1]) if @_ > 1;
186 $d = $d->Dump();
187 }
188 $d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
189 $d
190 } || "[unable to dump $_[0]: '$@']";
191}
161 192
162use JSON::Syck (); # TODO# replace by JSON::PC once working 193use JSON::Syck (); # TODO# replace by JSON::PC once working
163 194
164=item $ref = cf::from_json $json 195=item $ref = cf::from_json $json
165 196
181sub to_json($) { 212sub to_json($) {
182 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs 213 $JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
183 JSON::Syck::Dump $_[0] 214 JSON::Syck::Dump $_[0]
184} 215}
185 216
186=item my $guard = cf::guard { BLOCK }
187
188Run the given callback when the guard object gets destroyed (useful for
189coroutine cancellations).
190
191You can call C<< ->cancel >> on the guard object to stop the block from
192being executed.
193
194=cut
195
196sub guard(&) {
197 bless \(my $cb = $_[0]), cf::guard::;
198}
199
200sub cf::guard::cancel {
201 ${$_[0]} = sub { };
202}
203
204sub cf::guard::DESTROY {
205 ${$_[0]}->();
206}
207
208=item cf::lock_wait $string 217=item cf::lock_wait $string
209 218
210Wait until the given lock is available. See cf::lock_acquire. 219Wait until the given lock is available. See cf::lock_acquire.
211 220
212=item my $lock = cf::lock_acquire $string 221=item my $lock = cf::lock_acquire $string
213 222
214Wait until the given lock is available and then acquires it and returns 223Wait until the given lock is available and then acquires it and returns
215a guard object. If the guard object gets destroyed (goes out of scope, 224a Coro::guard object. If the guard object gets destroyed (goes out of scope,
216for example when the coroutine gets canceled), the lock is automatically 225for example when the coroutine gets canceled), the lock is automatically
217returned. 226returned.
218 227
219Lock names should begin with a unique identifier (for example, find_map 228Lock names should begin with a unique identifier (for example, cf::map::find
220uses map_find and load_map uses map_load). 229uses map_find and cf::map::load uses map_load).
221 230
222=cut 231=cut
223 232
224our %LOCK; 233our %LOCK;
225 234
239 # wait, to be sure we are not locked 248 # wait, to be sure we are not locked
240 lock_wait $key; 249 lock_wait $key;
241 250
242 $LOCK{$key} = []; 251 $LOCK{$key} = [];
243 252
244 cf::guard { 253 Coro::guard {
245 # wake up all waiters, to be on the safe side 254 # wake up all waiters, to be on the safe side
246 $_->ready for @{ delete $LOCK{$key} }; 255 $_->ready for @{ delete $LOCK{$key} };
247 } 256 }
248} 257}
258
259sub freeze_mainloop {
260 return unless $TICK_WATCHER->is_active;
261
262 my $guard = Coro::guard { $TICK_WATCHER->start };
263 $TICK_WATCHER->stop;
264 $guard
265}
266
267=item cf::async { BLOCK }
268
269Currently the same as Coro::async_pool, meaning you cannot use
270C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
271thing you are allowed to do is call C<prio> on it.
272
273=cut
274
275BEGIN { *async = \&Coro::async_pool }
249 276
250=item cf::sync_job { BLOCK } 277=item cf::sync_job { BLOCK }
251 278
252The design of crossfire+ requires that the main coro ($Coro::main) is 279The design of crossfire+ requires that the main coro ($Coro::main) is
253always able to handle events or runnable, as crossfire+ is only partly 280always able to handle events or runnable, as crossfire+ is only partly
267 # this is the main coro, too bad, we have to block 294 # this is the main coro, too bad, we have to block
268 # till the operation succeeds, freezing the server :/ 295 # till the operation succeeds, freezing the server :/
269 296
270 # TODO: use suspend/resume instead 297 # TODO: use suspend/resume instead
271 # (but this is cancel-safe) 298 # (but this is cancel-safe)
272 local $FREEZE = 1; 299 my $freeze_guard = freeze_mainloop;
273 300
274 my $busy = 1; 301 my $busy = 1;
275 my @res; 302 my @res;
276 303
277 (Coro::async { 304 (async {
278 @res = eval { $job->() }; 305 @res = eval { $job->() };
279 warn $@ if $@; 306 warn $@ if $@;
280 undef $busy; 307 undef $busy;
281 })->prio (Coro::PRIO_MAX); 308 })->prio (Coro::PRIO_MAX);
282 309
283 while ($busy) { 310 while ($busy) {
284 Coro::cede_notself; 311 Coro::cede or Event::one_event;
285 Event::one_event unless Coro::nready;
286 } 312 }
287 313
288 wantarray ? @res : $res[0] 314 wantarray ? @res : $res[0]
289 } else { 315 } else {
290 # we are in another coroutine, how wonderful, everything just works 316 # we are in another coroutine, how wonderful, everything just works
291 317
292 $job->() 318 $job->()
293 } 319 }
294} 320}
295 321
296=item $coro = cf::coro { BLOCK } 322=item $coro = cf::async_ext { BLOCK }
297 323
298Creates and returns a new coro. This coro is automcatially being canceled 324Like async, but this coro is automcatially being canceled when the
299when the extension calling this is being unloaded. 325extension calling this is being unloaded.
300 326
301=cut 327=cut
302 328
303sub coro(&) { 329sub async_ext(&) {
304 my $cb = shift; 330 my $cb = shift;
305 331
306 my $coro; $coro = async { 332 my $coro = &Coro::async ($cb);
307 eval {
308 $cb->();
309 };
310 warn $@ if $@;
311 };
312 333
313 $coro->on_destroy (sub { 334 $coro->on_destroy (sub {
314 delete $EXT_CORO{$coro+0}; 335 delete $EXT_CORO{$coro+0};
315 }); 336 });
316 $EXT_CORO{$coro+0} = $coro; 337 $EXT_CORO{$coro+0} = $coro;
345=cut 366=cut
346 367
347############################################################################# 368#############################################################################
348 369
349package cf::path; 370package cf::path;
371
372use overload
373 '""' => \&as_string;
374
375# used to convert map paths into valid unix filenames by repalcing / by ∕
376our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
350 377
351sub new { 378sub new {
352 my ($class, $path, $base) = @_; 379 my ($class, $path, $base) = @_;
353 380
354 $path = $path->as_string if ref $path; 381 $path = $path->as_string if ref $path;
360 # ?random/... random maps 387 # ?random/... random maps
361 # /! non-realised random map exit 388 # /! non-realised random map exit
362 # /... normal maps 389 # /... normal maps
363 # ~/... per-player maps without a specific player (DO NOT USE) 390 # ~/... per-player maps without a specific player (DO NOT USE)
364 # ~user/... per-player map of a specific user 391 # ~user/... per-player map of a specific user
392
393 $path =~ s/$PATH_SEP/\//go;
365 394
366 if ($path =~ /^{/) { 395 if ($path =~ /^{/) {
367 # fine as it is 396 # fine as it is
368 } elsif ($path =~ s{^\?random/}{}) { 397 } elsif ($path =~ s{^\?random/}{}) {
369 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data; 398 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
418# } 447# }
419} 448}
420 449
421# escape the /'s in the path 450# escape the /'s in the path
422sub _escaped_path { 451sub _escaped_path {
423 # ∕ is U+2215
424 (my $path = $_[0]{path}) =~ s/\///g; 452 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
425 $path 453 $path
426} 454}
427 455
428# the original (read-only) location 456# the original (read-only) location
429sub load_path { 457sub load_path {
1056}; 1084};
1057 1085
1058cf::map->attach (prio => -10000, package => cf::mapsupport::); 1086cf::map->attach (prio => -10000, package => cf::mapsupport::);
1059 1087
1060############################################################################# 1088#############################################################################
1061# load/save perl data associated with player->ob objects
1062
1063sub all_objects(@) {
1064 @_, map all_objects ($_->inv), @_
1065}
1066
1067# TODO: compatibility cruft, remove when no longer needed
1068cf::player->attach (
1069 on_load => sub {
1070 my ($pl, $path) = @_;
1071
1072 for my $o (all_objects $pl->ob) {
1073 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1074 $o->set_ob_key_value ("_perl_data");
1075
1076 %$o = %{ Storable::thaw pack "H*", $value };
1077 }
1078 }
1079 },
1080);
1081
1082#############################################################################
1083 1089
1084=head2 CORE EXTENSIONS 1090=head2 CORE EXTENSIONS
1085 1091
1086Functions and methods that extend core crossfire objects. 1092Functions and methods that extend core crossfire objects.
1087 1093
1094=cut
1095
1096package cf::player;
1097
1098use Coro::AIO;
1099
1088=head3 cf::player 1100=head3 cf::player
1089 1101
1090=over 4 1102=over 4
1091 1103
1092=item cf::player::exists $login 1104=item cf::player::find $login
1093 1105
1094Returns true when the given account exists. 1106Returns the given player object, loading it if necessary (might block).
1095 1107
1096=cut 1108=cut
1097 1109
1098sub cf::player::exists($) { 1110sub playerdir($) {
1099 cf::player::find $_[0] 1111 cf::localdir
1100 or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2; 1112 . "/"
1113 . cf::playerdir
1114 . "/"
1115 . (ref $_[0] ? $_[0]->ob->name : $_[0])
1116}
1117
1118sub path($) {
1119 my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
1120
1121 (playerdir $login) . "/$login.pl"
1122}
1123
1124sub find_active($) {
1125 $cf::PLAYER{$_[0]}
1126 and $cf::PLAYER{$_[0]}->active
1127 and $cf::PLAYER{$_[0]}
1128}
1129
1130sub exists($) {
1131 my ($login) = @_;
1132
1133 $cf::PLAYER{$login}
1134 or cf::sync_job { !aio_stat $login }
1135}
1136
1137sub find($) {
1138 return $cf::PLAYER{$_[0]} || do {
1139 my $login = $_[0];
1140
1141 my $guard = cf::lock_acquire "user_find:$login";
1142
1143 $cf::PLAYER{$_[0]} || do {
1144 my $pl = load_pl path $login
1145 or return;
1146 $cf::PLAYER{$login} = $pl
1147 }
1148 }
1149}
1150
1151sub save($) {
1152 my ($pl) = @_;
1153
1154 return if $pl->{deny_save};
1155
1156 my $path = path $pl;
1157 my $guard = cf::lock_acquire "user_save:$path";
1158
1159 return if $pl->{deny_save};
1160
1161 aio_mkdir playerdir $pl, 0770;
1162 $pl->{last_save} = $cf::RUNTIME;
1163
1164 $pl->save_pl ($path);
1165 Coro::cede;
1166}
1167
1168sub new($) {
1169 my ($login) = @_;
1170
1171 my $self = create;
1172
1173 $self->ob->name ($login);
1174 $self->{deny_save} = 1;
1175
1176 $cf::PLAYER{$login} = $self;
1177
1178 $self
1179}
1180
1181=item $pl->quit_character
1182
1183Nukes the player without looking back. If logged in, the connection will
1184be destroyed. May block for a long time.
1185
1186=cut
1187
1188sub quit_character {
1189 my ($pl) = @_;
1190
1191 $pl->{deny_save} = 1;
1192 $pl->password ("*"); # this should lock out the player until we nuked the dir
1193
1194 $pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
1195 $pl->deactivate;
1196 $pl->invoke (cf::EVENT_PLAYER_QUIT);
1197 $pl->ns->destroy if $pl->ns;
1198
1199 my $path = playerdir $pl;
1200 my $temp = "$path~$cf::RUNTIME~deleting~";
1201 aio_rename $path, $temp;
1202 delete $cf::PLAYER{$pl->ob->name};
1203 $pl->destroy;
1204 IO::AIO::aio_rmtree $temp;
1205}
1206
1207=item cf::player::list_logins
1208
1209Returns am arrayref of all valid playernames in the system, can take a
1210while and may block, so not sync_job-capable, ever.
1211
1212=cut
1213
1214sub list_logins {
1215 my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
1216 or return [];
1217
1218 my @logins;
1219
1220 for my $login (@$dirs) {
1221 my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1222 aio_read $fh, 0, 512, my $buf, 0 or next;
1223 $buf !~ /^password -------------$/m or next; # official not-valid tag
1224
1225 utf8::decode $login;
1226 push @logins, $login;
1227 }
1228
1229 \@logins
1230}
1231
1232=item $player->maps
1233
1234Returns an arrayref of cf::path's of all maps that are private for this
1235player. May block.
1236
1237=cut
1238
1239sub maps($) {
1240 my ($pl) = @_;
1241
1242 my $files = aio_readdir playerdir $pl
1243 or return;
1244
1245 my @paths;
1246
1247 for (@$files) {
1248 utf8::decode $_;
1249 next if /\.(?:pl|pst)$/;
1250 next unless /^$PATH_SEP/o;
1251
1252 push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;
1253 }
1254
1255 \@paths
1101} 1256}
1102 1257
1103=item $player->ext_reply ($msgid, $msgtype, %msg) 1258=item $player->ext_reply ($msgid, $msgtype, %msg)
1104 1259
1105Sends an ext reply to the player. 1260Sends an ext reply to the player.
1106 1261
1107=cut 1262=cut
1108 1263
1109sub cf::player::ext_reply($$$%) { 1264sub ext_reply($$$%) {
1110 my ($self, $id, %msg) = @_; 1265 my ($self, $id, %msg) = @_;
1111 1266
1112 $msg{msgid} = $id; 1267 $msg{msgid} = $id;
1113 1268
1114 $self->send ("ext " . to_json \%msg); 1269 $self->send ("ext " . cf::to_json \%msg);
1115} 1270}
1271
1272package cf;
1116 1273
1117=back 1274=back
1118 1275
1119 1276
1120=head3 cf::map 1277=head3 cf::map
1126package cf::map; 1283package cf::map;
1127 1284
1128use Fcntl; 1285use Fcntl;
1129use Coro::AIO; 1286use Coro::AIO;
1130 1287
1131our $MAX_RESET = 7200; 1288our $MAX_RESET = 3600;
1132our $DEFAULT_RESET = 3600; 1289our $DEFAULT_RESET = 3000;
1133 1290
1134sub generate_random_map { 1291sub generate_random_map {
1135 my ($path, $rmp) = @_; 1292 my ($path, $rmp) = @_;
1136 1293
1137 # mit "rum" bekleckern, nicht 1294 # mit "rum" bekleckern, nicht
1167 or return; 1324 or return;
1168 1325
1169 my $map = cf::map::new 1326 my $map = cf::map::new
1170 or return; 1327 or return;
1171 1328
1329 # for better error messages only, will be overwritten
1330 $map->path ($path);
1331
1172 $map->load_header ($path) 1332 $map->load_header ($path)
1173 or return; 1333 or return;
1174 1334
1175 $map->{load_path} = $path; 1335 $map->{load_path} = $path;
1176 1336
1177 $map 1337 $map
1178} 1338}
1179 1339
1180sub find_map; 1340sub find;
1181sub find_map { 1341sub find {
1182 my ($path, $origin) = @_; 1342 my ($path, $origin) = @_;
1183 1343
1184 #warn "find_map<$path,$origin>\n";#d# 1344 #warn "find<$path,$origin>\n";#d#
1185 1345
1186 $path = new cf::path $path, $origin && $origin->path; 1346 $path = new cf::path $path, $origin && $origin->path;
1187 my $key = $path->as_string; 1347 my $key = $path->as_string;
1188 1348
1189 cf::lock_wait "map_find:$key"; 1349 cf::lock_wait "map_find:$key";
1192 my $guard = cf::lock_acquire "map_find:$key"; 1352 my $guard = cf::lock_acquire "map_find:$key";
1193 1353
1194 # do it the slow way 1354 # do it the slow way
1195 my $map = try_load_header $path->save_path; 1355 my $map = try_load_header $path->save_path;
1196 1356
1357 Coro::cede;
1358
1197 if ($map) { 1359 if ($map) {
1360 $map->last_access ((delete $map->{last_access})
1361 || $cf::RUNTIME); #d#
1198 # safety 1362 # safety
1199 $map->{instantiate_time} = $cf::RUNTIME 1363 $map->{instantiate_time} = $cf::RUNTIME
1200 if $map->{instantiate_time} > $cf::RUNTIME; 1364 if $map->{instantiate_time} > $cf::RUNTIME;
1201 } else { 1365 } else {
1202 if (my $rmp = $path->random_map_params) { 1366 if (my $rmp = $path->random_map_params) {
1207 1371
1208 $map or return; 1372 $map or return;
1209 1373
1210 $map->{load_original} = 1; 1374 $map->{load_original} = 1;
1211 $map->{instantiate_time} = $cf::RUNTIME; 1375 $map->{instantiate_time} = $cf::RUNTIME;
1376 $map->last_access ($cf::RUNTIME);
1212 $map->instantiate; 1377 $map->instantiate;
1213 1378
1214 # per-player maps become, after loading, normal maps 1379 # per-player maps become, after loading, normal maps
1215 $map->per_player (0) if $path->{user_rel}; 1380 $map->per_player (0) if $path->{user_rel};
1216 } 1381 }
1217 1382
1218 $map->path ($key); 1383 $map->path ($key);
1219 $map->{path} = $path; 1384 $map->{path} = $path;
1220 $map->{last_save} = $cf::RUNTIME; 1385 $map->{last_save} = $cf::RUNTIME;
1221 $map->last_access ($cf::RUNTIME); 1386
1387 Coro::cede;
1222 1388
1223 if ($map->should_reset) { 1389 if ($map->should_reset) {
1224 $map->reset; 1390 $map->reset;
1225 undef $guard; 1391 undef $guard;
1226 $map = find_map $path 1392 $map = find $path
1227 or return; 1393 or return;
1228 } 1394 }
1229 1395
1230 $cf::MAP{$key} = $map 1396 $cf::MAP{$key} = $map
1231 } 1397 }
1253 if (aio_open $uniq, O_RDONLY, 0) { 1419 if (aio_open $uniq, O_RDONLY, 0) {
1254 $self->clear_unique_items; 1420 $self->clear_unique_items;
1255 $self->load_objects ($uniq, 0); 1421 $self->load_objects ($uniq, 0);
1256 } 1422 }
1257 } 1423 }
1424
1425 Coro::cede;
1258 1426
1259 # now do the right thing for maps 1427 # now do the right thing for maps
1260 $self->link_multipart_objects; 1428 $self->link_multipart_objects;
1261 1429
1262 if ($self->{path}->is_style_map) { 1430 if ($self->{path}->is_style_map) {
1270 $self->difficulty ($self->estimate_difficulty) 1438 $self->difficulty ($self->estimate_difficulty)
1271 unless $self->difficulty; 1439 unless $self->difficulty;
1272 $self->activate; 1440 $self->activate;
1273 } 1441 }
1274 1442
1443 Coro::cede;
1444
1275 $self->in_memory (cf::MAP_IN_MEMORY); 1445 $self->in_memory (cf::MAP_IN_MEMORY);
1276} 1446}
1277 1447
1278sub load_map_sync { 1448# find and load all maps in the 3x3 area around a map
1449sub load_diag {
1450 my ($map) = @_;
1451
1452 my @diag; # diagonal neighbours
1453
1454 for (0 .. 3) {
1455 my $neigh = $map->tile_path ($_)
1456 or next;
1457 $neigh = find $neigh, $map
1458 or next;
1459 $neigh->load;
1460
1461 push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
1462 [$neigh->tile_path (($_ + 1) % 4), $neigh];
1463 }
1464
1465 for (@diag) {
1466 my $neigh = find @$_
1467 or next;
1468 $neigh->load;
1469 }
1470}
1471
1472sub find_sync {
1279 my ($path, $origin) = @_; 1473 my ($path, $origin) = @_;
1280 1474
1281 #warn "load_map_sync<$path, $origin>\n";#d# 1475 cf::sync_job { find $path, $origin }
1476}
1282 1477
1283 cf::sync_job { 1478sub do_load_sync {
1284 my $map = cf::map::find_map $path, $origin 1479 my ($map) = @_;
1480
1481 cf::sync_job { $map->load };
1482}
1483
1484our %MAP_PREFETCH;
1485our $MAP_PREFETCHER = Coro::async {
1486 while () {
1487 while (%MAP_PREFETCH) {
1488 my $key = each %MAP_PREFETCH
1285 or return; 1489 or next;
1490 my $path = delete $MAP_PREFETCH{$key};
1491
1492 my $map = find $path
1493 or next;
1286 $map->load; 1494 $map->load;
1287 $map 1495 }
1496 Coro::schedule;
1288 } 1497 }
1498};
1499
1500sub find_async {
1501 my ($path, $origin) = @_;
1502
1503 $path = new cf::path $path, $origin && $origin->path;
1504 my $key = $path->as_string;
1505
1506 if (my $map = $cf::MAP{$key}) {
1507 return $map if $map->in_memory == cf::MAP_IN_MEMORY;
1508 }
1509
1510 $MAP_PREFETCH{$key} = $path;
1511 $MAP_PREFETCHER->ready;
1512
1513 ()
1289} 1514}
1290 1515
1291sub save { 1516sub save {
1292 my ($self) = @_; 1517 my ($self) = @_;
1293 1518
1519 my $lock = cf::lock_acquire "map_data:" . $self->path;
1520
1294 $self->{last_save} = $cf::RUNTIME; 1521 $self->{last_save} = $cf::RUNTIME;
1295 1522
1296 return unless $self->dirty; 1523 return unless $self->dirty;
1297 1524
1298 my $save = $self->{path}->save_path; utf8::encode $save; 1525 my $save = $self->{path}->save_path; utf8::encode $save;
1299 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1526 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1300 1527
1301 $self->{load_path} = $save; 1528 $self->{load_path} = $save;
1302 1529
1303 return if $self->{deny_save}; 1530 return if $self->{deny_save};
1531
1532 local $self->{last_access} = $self->last_access;#d#
1533
1534 cf::async {
1535 $_->contr->save for $self->players;
1536 };
1304 1537
1305 if ($uniq) { 1538 if ($uniq) {
1306 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1539 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1307 $self->save_objects ($uniq, cf::IO_UNIQUES); 1540 $self->save_objects ($uniq, cf::IO_UNIQUES);
1308 } else { 1541 } else {
1311} 1544}
1312 1545
1313sub swap_out { 1546sub swap_out {
1314 my ($self) = @_; 1547 my ($self) = @_;
1315 1548
1549 # save first because save cedes
1550 $self->save;
1551
1552 my $lock = cf::lock_acquire "map_data:" . $self->path;
1553
1316 return if $self->players; 1554 return if $self->players;
1317 return if $self->in_memory != cf::MAP_IN_MEMORY; 1555 return if $self->in_memory != cf::MAP_IN_MEMORY;
1318 return if $self->{deny_save}; 1556 return if $self->{deny_save};
1319 1557
1320 $self->save;
1321 $self->clear; 1558 $self->clear;
1322 $self->in_memory (cf::MAP_SWAPPED); 1559 $self->in_memory (cf::MAP_SWAPPED);
1323} 1560}
1324 1561
1325sub reset_at { 1562sub reset_at {
1363} 1600}
1364 1601
1365sub reset { 1602sub reset {
1366 my ($self) = @_; 1603 my ($self) = @_;
1367 1604
1605 my $lock = cf::lock_acquire "map_data:" . $self->path;
1606
1368 return if $self->players; 1607 return if $self->players;
1369 return if $self->{path}{user_rel};#d# 1608 return if $self->{path}{user_rel};#d#
1370 1609
1371 warn "resetting map ", $self->path;#d# 1610 warn "resetting map ", $self->path;#d#
1372 1611
1391 1630
1392sub customise_for { 1631sub customise_for {
1393 my ($map, $ob) = @_; 1632 my ($map, $ob) = @_;
1394 1633
1395 if ($map->per_player) { 1634 if ($map->per_player) {
1396 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path}; 1635 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};
1397 } 1636 }
1398 1637
1399 $map 1638 $map
1400} 1639}
1401 1640
1402sub emergency_save { 1641=item cf::map::unique_maps
1403 local $cf::FREEZE = 1;
1404 1642
1405 warn "enter emergency map save\n"; 1643Returns an arrayref of cf::path's of all shared maps that have
1644instantiated unique items. May block.
1406 1645
1407 cf::sync_job { 1646=cut
1408 warn "begin emergency map save\n"; 1647
1409 $_->save for values %cf::MAP; 1648sub unique_maps() {
1649 my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
1650 or return;
1651
1652 my @paths;
1653
1654 for (@$files) {
1655 utf8::decode $_;
1656 next if /\.pst$/;
1657 next unless /^$PATH_SEP/o;
1658
1659 push @paths, new cf::path $_;
1410 }; 1660 }
1411 1661
1412 warn "end emergency map save\n"; 1662 \@paths
1413} 1663}
1414 1664
1415package cf; 1665package cf;
1416 1666
1417=back 1667=back
1418 1668
1669=head3 cf::object
1670
1671=cut
1672
1673package cf::object;
1674
1675=over 4
1676
1677=item $ob->inv_recursive
1678
1679Returns the inventory of the object _and_ their inventories, recursively.
1680
1681=cut
1682
1683sub inv_recursive_;
1684sub inv_recursive_ {
1685 map { $_, inv_recursive_ $_->inv } @_
1686}
1687
1688sub inv_recursive {
1689 inv_recursive_ inv $_[0]
1690}
1691
1692package cf;
1693
1694=back
1419 1695
1420=head3 cf::object::player 1696=head3 cf::object::player
1421 1697
1422=over 4 1698=over 4
1423 1699
1498 my $link_pos = delete $self->{_link_pos}; 1774 my $link_pos = delete $self->{_link_pos};
1499 1775
1500 unless ($map) { 1776 unless ($map) {
1501 # restore original map position 1777 # restore original map position
1502 ($map, $x, $y) = @{ $link_pos || [] }; 1778 ($map, $x, $y) = @{ $link_pos || [] };
1503 $map = cf::map::find_map $map; 1779 $map = cf::map::find $map;
1504 1780
1505 unless ($map) { 1781 unless ($map) {
1506 ($map, $x, $y) = @$EMERGENCY_POSITION; 1782 ($map, $x, $y) = @$EMERGENCY_POSITION;
1507 $map = cf::map::find_map $map 1783 $map = cf::map::find $map
1508 or die "FATAL: cannot load emergency map\n"; 1784 or die "FATAL: cannot load emergency map\n";
1509 } 1785 }
1510 } 1786 }
1511 1787
1512 ($x, $y) = (-1, -1) 1788 ($x, $y) = (-1, -1)
1515 # use -1 or undef as default coordinates, not 0, 0 1791 # use -1 or undef as default coordinates, not 0, 0
1516 ($x, $y) = ($map->enter_x, $map->enter_y) 1792 ($x, $y) = ($map->enter_x, $map->enter_y)
1517 if $x <=0 && $y <= 0; 1793 if $x <=0 && $y <= 0;
1518 1794
1519 $map->load; 1795 $map->load;
1796 $map->load_diag;
1520 1797
1798 return unless $self->contr->active;
1521 $self->activate_recursive; 1799 $self->activate_recursive;
1522 $self->enter_map ($map, $x, $y); 1800 $self->enter_map ($map, $x, $y);
1523} 1801}
1524 1802
1525cf::player->attach ( 1803cf::player->attach (
1538 1816
1539 # try to abort aborted map switching on player login :) 1817 # try to abort aborted map switching on player login :)
1540 # should happen only on crashes 1818 # should happen only on crashes
1541 if ($pl->ob->{_link_pos}) { 1819 if ($pl->ob->{_link_pos}) {
1542 $pl->ob->enter_link; 1820 $pl->ob->enter_link;
1543 Coro::async { 1821 (async {
1544 # we need this sleep as the login has a concurrent enter_exit running 1822 # we need this sleep as the login has a concurrent enter_exit running
1545 # and this sleep increases chances of the player not ending up in scorn 1823 # and this sleep increases chances of the player not ending up in scorn
1824 $pl->ob->reply (undef,
1825 "There was an internal problem at your last logout, "
1826 . "the server will try to bring you to your intended destination in a second.",
1827 cf::NDI_RED);
1546 Coro::Timer::sleep 1; 1828 Coro::Timer::sleep 1;
1547 $pl->ob->leave_link; 1829 $pl->ob->leave_link;
1548 }; 1830 })->prio (2);
1549 } 1831 }
1550 }, 1832 },
1551); 1833);
1552 1834
1553=item $player_object->goto_map ($path, $x, $y) 1835=item $player_object->goto ($path, $x, $y)
1554 1836
1555=cut 1837=cut
1556 1838
1557sub cf::object::player::goto_map { 1839sub cf::object::player::goto {
1558 my ($self, $path, $x, $y) = @_; 1840 my ($self, $path, $x, $y) = @_;
1559 1841
1842 $path = new cf::path $path;
1843
1560 $self->enter_link; 1844 $self->enter_link;
1561 1845
1562 (Coro::async { 1846 (async {
1563 $path = new cf::path $path;
1564
1565 my $map = cf::map::find_map $path->as_string; 1847 my $map = cf::map::find $path->as_string;
1566 $map = $map->customise_for ($self) if $map; 1848 $map = $map->customise_for ($self) if $map;
1567 1849
1568# warn "entering ", $map->path, " at ($x, $y)\n" 1850# warn "entering ", $map->path, " at ($x, $y)\n"
1569# if $map; 1851# if $map;
1570 1852
1571 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED); 1853 $map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1572 1854
1573 $self->leave_link ($map, $x, $y); 1855 $self->leave_link ($map, $x, $y);
1574 })->prio (1); 1856 })->prio (1);
1575} 1857}
1576 1858
1629 1911
1630 return unless $self->type == cf::PLAYER; 1912 return unless $self->type == cf::PLAYER;
1631 1913
1632 $self->enter_link; 1914 $self->enter_link;
1633 1915
1634 (Coro::async { 1916 (async {
1917 $self->deactivate_recursive; # just to be sure
1635 unless (eval { 1918 unless (eval {
1636
1637 prepare_random_map $exit 1919 prepare_random_map $exit
1638 if $exit->slaying eq "/!"; 1920 if $exit->slaying eq "/!";
1639 1921
1640 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path; 1922 my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
1641 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp); 1923 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1642 1924
1643 1; 1925 1;
1644 }) { 1926 }) {
1645 $self->message ("Something went wrong deep within the crossfire server. " 1927 $self->message ("Something went wrong deep within the crossfire server. "
1646 . "I'll try to bring you back to the map you were before. " 1928 . "I'll try to bring you back to the map you were before. "
1647 . "Please report this to the dungeon master", 1929 . "Please report this to the dungeon master!",
1648 cf::NDI_UNIQUE | cf::NDI_RED); 1930 cf::NDI_UNIQUE | cf::NDI_RED);
1649 1931
1650 warn "ERROR in enter_exit: $@"; 1932 warn "ERROR in enter_exit: $@";
1651 $self->leave_link; 1933 $self->leave_link;
1652 } 1934 }
1703 on_reply => sub { 1985 on_reply => sub {
1704 my ($ns, $msg) = @_; 1986 my ($ns, $msg) = @_;
1705 1987
1706 # this weird shuffling is so that direct followup queries 1988 # this weird shuffling is so that direct followup queries
1707 # get handled first 1989 # get handled first
1708 my $queue = delete $ns->{query_queue}; 1990 my $queue = delete $ns->{query_queue}
1991 or return; # be conservative, not sure how that can happen, but we saw a crash here
1709 1992
1710 (shift @$queue)->[1]->($msg); 1993 (shift @$queue)->[1]->($msg);
1711 1994
1712 push @{ $ns->{query_queue} }, @$queue; 1995 push @{ $ns->{query_queue} }, @$queue;
1713 1996
1719 } 2002 }
1720 } 2003 }
1721 }, 2004 },
1722); 2005);
1723 2006
1724=item $client->coro (\&cb) 2007=item $client->async (\&cb)
1725 2008
1726Create a new coroutine, running the specified callback. The coroutine will 2009Create a new coroutine, running the specified callback. The coroutine will
1727be automatically cancelled when the client gets destroyed (e.g. on logout, 2010be automatically cancelled when the client gets destroyed (e.g. on logout,
1728or loss of connection). 2011or loss of connection).
1729 2012
1730=cut 2013=cut
1731 2014
1732sub cf::client::coro { 2015sub cf::client::async {
1733 my ($self, $cb) = @_; 2016 my ($self, $cb) = @_;
1734 2017
1735 my $coro; $coro = async { 2018 my $coro = &Coro::async ($cb);
1736 eval {
1737 $cb->();
1738 };
1739 warn $@ if $@;
1740 };
1741 2019
1742 $coro->on_destroy (sub { 2020 $coro->on_destroy (sub {
1743 delete $self->{_coro}{$coro+0}; 2021 delete $self->{_coro}{$coro+0};
1744 }); 2022 });
1745 2023
1980 open my $fh, "<:utf8", cf::confdir . "/config" 2258 open my $fh, "<:utf8", cf::confdir . "/config"
1981 or return; 2259 or return;
1982 2260
1983 local $/; 2261 local $/;
1984 *CFG = YAML::Syck::Load <$fh>; 2262 *CFG = YAML::Syck::Load <$fh>;
2263
2264 $EMERGENCY_POSITION = $CFG{emergency_position} || ["/world/world_105_115", 5, 37];
2265
2266 $cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
2267 $cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2268
2269 if (exists $CFG{mlockall}) {
2270 eval {
2271 $CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2272 and die "WARNING: m(un)lockall failed: $!\n";
2273 };
2274 warn $@ if $@;
2275 }
1985} 2276}
1986 2277
1987sub main { 2278sub main {
1988 # we must not ever block the main coroutine 2279 # we must not ever block the main coroutine
1989 local $Coro::idle = sub { 2280 local $Coro::idle = sub {
1990 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d# 2281 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1991 (Coro::unblock_sub {
1992 Event::one_event; 2282 async { Event::one_event };
1993 })->();
1994 }; 2283 };
1995 2284
1996 cfg_load; 2285 cfg_load;
1997 db_load; 2286 db_load;
1998 load_extensions; 2287 load_extensions;
1999 Event::loop; 2288 Event::loop;
2000} 2289}
2001 2290
2002############################################################################# 2291#############################################################################
2003# initialisation 2292# initialisation and cleanup
2293
2294# install some emergency cleanup handlers
2295BEGIN {
2296 for my $signal (qw(INT HUP TERM)) {
2297 Event->signal (
2298 data => WF_AUTOCANCEL,
2299 signal => $signal,
2300 cb => sub {
2301 cf::cleanup "SIG$signal";
2302 },
2303 );
2304 }
2305}
2306
2307sub emergency_save() {
2308 my $freeze_guard = cf::freeze_mainloop;
2309
2310 warn "enter emergency perl save\n";
2311
2312 cf::sync_job {
2313 # use a peculiar iteration method to avoid tripping on perl
2314 # refcount bugs in for. also avoids problems with players
2315 # and maps saved/Destroyed asynchronously.
2316 warn "begin emergency player save\n";
2317 for my $login (keys %cf::PLAYER) {
2318 my $pl = $cf::PLAYER{$login} or next;
2319 $pl->valid or next;
2320 $pl->save;
2321 }
2322 warn "end emergency player save\n";
2323
2324 warn "begin emergency map save\n";
2325 for my $path (keys %cf::MAP) {
2326 my $map = $cf::MAP{$path} or next;
2327 $map->valid or next;
2328 $map->save;
2329 }
2330 warn "end emergency map save\n";
2331 };
2332
2333 warn "leave emergency perl save\n";
2334}
2004 2335
2005sub reload() { 2336sub reload() {
2006 # can/must only be called in main 2337 # can/must only be called in main
2007 if ($Coro::current != $Coro::main) { 2338 if ($Coro::current != $Coro::main) {
2008 warn "can only reload from main coroutine\n"; 2339 warn "can only reload from main coroutine\n";
2009 return; 2340 return;
2010 } 2341 }
2011 2342
2012 warn "reloading..."; 2343 warn "reloading...";
2013 2344
2014 local $FREEZE = 1; 2345 my $guard = freeze_mainloop;
2015 cf::emergency_save; 2346 cf::emergency_save;
2016 2347
2017 eval { 2348 eval {
2018 # if anything goes wrong in here, we should simply crash as we already saved 2349 # if anything goes wrong in here, we should simply crash as we already saved
2019 2350
2081 cf::load_extensions; 2412 cf::load_extensions;
2082 2413
2083 # reattach attachments to objects 2414 # reattach attachments to objects
2084 warn "reattach"; 2415 warn "reattach";
2085 _global_reattach; 2416 _global_reattach;
2417 reattach $_ for values %MAP;
2086 }; 2418 };
2087 2419
2088 if ($@) { 2420 if ($@) {
2089 warn $@; 2421 warn $@;
2090 warn "error while reloading, exiting."; 2422 warn "error while reloading, exiting.";
2106 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path"; 2438 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2107 $LINK_MAP->in_memory (MAP_IN_MEMORY); 2439 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2108 2440
2109 # dirty hack because... archetypes are not yet loaded 2441 # dirty hack because... archetypes are not yet loaded
2110 Event->timer ( 2442 Event->timer (
2111 after => 2, 2443 after => 10,
2112 cb => sub { 2444 cb => sub {
2113 $_[0]->w->cancel; 2445 $_[0]->w->cancel;
2114 2446
2115 # provide some exits "home" 2447 # provide some exits "home"
2116 my $exit = cf::object::new "exit"; 2448 my $exit = cf::object::new "exit";
2155 reentrant => 0, 2487 reentrant => 0,
2156 prio => 0, 2488 prio => 0,
2157 at => $NEXT_TICK || $TICK, 2489 at => $NEXT_TICK || $TICK,
2158 data => WF_AUTOCANCEL, 2490 data => WF_AUTOCANCEL,
2159 cb => sub { 2491 cb => sub {
2160 unless ($FREEZE) {
2161 cf::server_tick; # one server iteration 2492 cf::server_tick; # one server iteration
2162 $RUNTIME += $TICK; 2493 $RUNTIME += $TICK;
2163 }
2164
2165 $NEXT_TICK += $TICK; 2494 $NEXT_TICK += $TICK;
2495
2496 $WAIT_FOR_TICK->broadcast;
2497 $WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2166 2498
2167 # if we are delayed by four ticks or more, skip them all 2499 # if we are delayed by four ticks or more, skip them all
2168 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2500 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2169 2501
2170 $TICK_WATCHER->at ($NEXT_TICK); 2502 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines