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.128 by root, Wed Jan 3 00:28:47 2007 UTC vs.
Revision 1.158 by root, Wed Jan 10 19:52:43 2007 UTC

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}
249 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
250=item cf::async { BLOCK } 267=item cf::async { BLOCK }
251 268
252Like C<Coro::async>, but runs the given BLOCK in an eval and only logs the 269Currently the same as Coro::async_pool, meaning you cannot use
253error instead of exiting the server in case of a problem. 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.
254 272
255=cut 273=cut
256 274
257sub async(&) { 275BEGIN { *async = \&Coro::async_pool }
258 my ($cb) = @_;
259
260 Coro::async {
261 eval { $cb->() };
262 warn $@ if $@;
263 }
264}
265 276
266=item cf::sync_job { BLOCK } 277=item cf::sync_job { BLOCK }
267 278
268The design of crossfire+ requires that the main coro ($Coro::main) is 279The design of crossfire+ requires that the main coro ($Coro::main) is
269always able to handle events or runnable, as crossfire+ is only partly 280always able to handle events or runnable, as crossfire+ is only partly
283 # this is the main coro, too bad, we have to block 294 # this is the main coro, too bad, we have to block
284 # till the operation succeeds, freezing the server :/ 295 # till the operation succeeds, freezing the server :/
285 296
286 # TODO: use suspend/resume instead 297 # TODO: use suspend/resume instead
287 # (but this is cancel-safe) 298 # (but this is cancel-safe)
288 local $FREEZE = 1; 299 my $freeze_guard = freeze_mainloop;
289 300
290 my $busy = 1; 301 my $busy = 1;
291 my @res; 302 my @res;
292 303
293 (Coro::async { 304 (async {
294 @res = eval { $job->() }; 305 @res = eval { $job->() };
295 warn $@ if $@; 306 warn $@ if $@;
296 undef $busy; 307 undef $busy;
297 })->prio (Coro::PRIO_MAX); 308 })->prio (Coro::PRIO_MAX);
298 309
299 while ($busy) { 310 while ($busy) {
300 Coro::cede_notself; 311 Coro::cede or Event::one_event;
301 Event::one_event unless Coro::nready;
302 } 312 }
303 313
304 wantarray ? @res : $res[0] 314 wantarray ? @res : $res[0]
305 } else { 315 } else {
306 # we are in another coroutine, how wonderful, everything just works 316 # we are in another coroutine, how wonderful, everything just works
307 317
308 $job->() 318 $job->()
309 } 319 }
310} 320}
311 321
312=item $coro = cf::coro { BLOCK } 322=item $coro = cf::async_ext { BLOCK }
313 323
314Creates and returns a new coro. This coro is automcatially being canceled 324Like async, but this coro is automcatially being canceled when the
315when the extension calling this is being unloaded. 325extension calling this is being unloaded.
316 326
317=cut 327=cut
318 328
319sub coro(&) { 329sub async_ext(&) {
320 my $cb = shift; 330 my $cb = shift;
321 331
322 my $coro = &cf::async ($cb); 332 my $coro = &Coro::async ($cb);
323 333
324 $coro->on_destroy (sub { 334 $coro->on_destroy (sub {
325 delete $EXT_CORO{$coro+0}; 335 delete $EXT_CORO{$coro+0};
326 }); 336 });
327 $EXT_CORO{$coro+0} = $coro; 337 $EXT_CORO{$coro+0} = $coro;
356=cut 366=cut
357 367
358############################################################################# 368#############################################################################
359 369
360package 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
361 377
362sub new { 378sub new {
363 my ($class, $path, $base) = @_; 379 my ($class, $path, $base) = @_;
364 380
365 $path = $path->as_string if ref $path; 381 $path = $path->as_string if ref $path;
371 # ?random/... random maps 387 # ?random/... random maps
372 # /! non-realised random map exit 388 # /! non-realised random map exit
373 # /... normal maps 389 # /... normal maps
374 # ~/... per-player maps without a specific player (DO NOT USE) 390 # ~/... per-player maps without a specific player (DO NOT USE)
375 # ~user/... per-player map of a specific user 391 # ~user/... per-player map of a specific user
392
393 $path =~ s/$PATH_SEP/\//go;
376 394
377 if ($path =~ /^{/) { 395 if ($path =~ /^{/) {
378 # fine as it is 396 # fine as it is
379 } elsif ($path =~ s{^\?random/}{}) { 397 } elsif ($path =~ s{^\?random/}{}) {
380 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data; 398 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
429# } 447# }
430} 448}
431 449
432# escape the /'s in the path 450# escape the /'s in the path
433sub _escaped_path { 451sub _escaped_path {
434 # ∕ is U+2215
435 (my $path = $_[0]{path}) =~ s/\///g; 452 (my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
436 $path 453 $path
437} 454}
438 455
439# the original (read-only) location 456# the original (read-only) location
440sub load_path { 457sub load_path {
1067}; 1084};
1068 1085
1069cf::map->attach (prio => -10000, package => cf::mapsupport::); 1086cf::map->attach (prio => -10000, package => cf::mapsupport::);
1070 1087
1071############################################################################# 1088#############################################################################
1072# load/save perl data associated with player->ob objects
1073
1074sub all_objects(@) {
1075 @_, map all_objects ($_->inv), @_
1076}
1077
1078# TODO: compatibility cruft, remove when no longer needed
1079cf::player->attach (
1080 on_load => sub {
1081 my ($pl, $path) = @_;
1082
1083 for my $o (all_objects $pl->ob) {
1084 if (my $value = $o->get_ob_key_value ("_perl_data")) {
1085 $o->set_ob_key_value ("_perl_data");
1086
1087 %$o = %{ Storable::thaw pack "H*", $value };
1088 }
1089 }
1090 },
1091);
1092
1093#############################################################################
1094 1089
1095=head2 CORE EXTENSIONS 1090=head2 CORE EXTENSIONS
1096 1091
1097Functions and methods that extend core crossfire objects. 1092Functions and methods that extend core crossfire objects.
1098 1093
1094=cut
1095
1096package cf::player;
1097
1098use Coro::AIO;
1099
1099=head3 cf::player 1100=head3 cf::player
1100 1101
1101=over 4 1102=over 4
1102 1103
1103=item cf::player::exists $login 1104=item cf::player::find $login
1104 1105
1105Returns true when the given account exists. 1106Returns the given player object, loading it if necessary (might block).
1106 1107
1107=cut 1108=cut
1108 1109
1109sub cf::player::exists($) { 1110sub playerdir($) {
1110 cf::player::find $_[0] 1111 cf::localdir
1111 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
1112} 1256}
1113 1257
1114=item $player->ext_reply ($msgid, $msgtype, %msg) 1258=item $player->ext_reply ($msgid, $msgtype, %msg)
1115 1259
1116Sends an ext reply to the player. 1260Sends an ext reply to the player.
1117 1261
1118=cut 1262=cut
1119 1263
1120sub cf::player::ext_reply($$$%) { 1264sub ext_reply($$$%) {
1121 my ($self, $id, %msg) = @_; 1265 my ($self, $id, %msg) = @_;
1122 1266
1123 $msg{msgid} = $id; 1267 $msg{msgid} = $id;
1124 1268
1125 $self->send ("ext " . to_json \%msg); 1269 $self->send ("ext " . cf::to_json \%msg);
1126} 1270}
1271
1272package cf;
1127 1273
1128=back 1274=back
1129 1275
1130 1276
1131=head3 cf::map 1277=head3 cf::map
1137package cf::map; 1283package cf::map;
1138 1284
1139use Fcntl; 1285use Fcntl;
1140use Coro::AIO; 1286use Coro::AIO;
1141 1287
1142our $MAX_RESET = 7200; 1288our $MAX_RESET = 3600;
1143our $DEFAULT_RESET = 3600; 1289our $DEFAULT_RESET = 3000;
1144 1290
1145sub generate_random_map { 1291sub generate_random_map {
1146 my ($path, $rmp) = @_; 1292 my ($path, $rmp) = @_;
1147 1293
1148 # mit "rum" bekleckern, nicht 1294 # mit "rum" bekleckern, nicht
1178 or return; 1324 or return;
1179 1325
1180 my $map = cf::map::new 1326 my $map = cf::map::new
1181 or return; 1327 or return;
1182 1328
1329 # for better error messages only, will be overwritten
1330 $map->path ($path);
1331
1183 $map->load_header ($path) 1332 $map->load_header ($path)
1184 or return; 1333 or return;
1185 1334
1186 $map->{load_path} = $path; 1335 $map->{load_path} = $path;
1187 1336
1188 $map 1337 $map
1189} 1338}
1190 1339
1191sub find_map; 1340sub find;
1192sub find_map { 1341sub find {
1193 my ($path, $origin) = @_; 1342 my ($path, $origin) = @_;
1194 1343
1195 #warn "find_map<$path,$origin>\n";#d# 1344 #warn "find<$path,$origin>\n";#d#
1196 1345
1197 $path = new cf::path $path, $origin && $origin->path; 1346 $path = new cf::path $path, $origin && $origin->path;
1198 my $key = $path->as_string; 1347 my $key = $path->as_string;
1199 1348
1200 cf::lock_wait "map_find:$key"; 1349 cf::lock_wait "map_find:$key";
1203 my $guard = cf::lock_acquire "map_find:$key"; 1352 my $guard = cf::lock_acquire "map_find:$key";
1204 1353
1205 # do it the slow way 1354 # do it the slow way
1206 my $map = try_load_header $path->save_path; 1355 my $map = try_load_header $path->save_path;
1207 1356
1357 Coro::cede;
1358
1208 if ($map) { 1359 if ($map) {
1360 $map->last_access ((delete $map->{last_access})
1361 || $cf::RUNTIME); #d#
1209 # safety 1362 # safety
1210 $map->{instantiate_time} = $cf::RUNTIME 1363 $map->{instantiate_time} = $cf::RUNTIME
1211 if $map->{instantiate_time} > $cf::RUNTIME; 1364 if $map->{instantiate_time} > $cf::RUNTIME;
1212 } else { 1365 } else {
1213 if (my $rmp = $path->random_map_params) { 1366 if (my $rmp = $path->random_map_params) {
1218 1371
1219 $map or return; 1372 $map or return;
1220 1373
1221 $map->{load_original} = 1; 1374 $map->{load_original} = 1;
1222 $map->{instantiate_time} = $cf::RUNTIME; 1375 $map->{instantiate_time} = $cf::RUNTIME;
1376 $map->last_access ($cf::RUNTIME);
1223 $map->instantiate; 1377 $map->instantiate;
1224 1378
1225 # per-player maps become, after loading, normal maps 1379 # per-player maps become, after loading, normal maps
1226 $map->per_player (0) if $path->{user_rel}; 1380 $map->per_player (0) if $path->{user_rel};
1227 } 1381 }
1228 1382
1229 $map->path ($key); 1383 $map->path ($key);
1230 $map->{path} = $path; 1384 $map->{path} = $path;
1231 $map->{last_save} = $cf::RUNTIME; 1385 $map->{last_save} = $cf::RUNTIME;
1232 $map->last_access ($cf::RUNTIME); 1386
1387 Coro::cede;
1233 1388
1234 if ($map->should_reset) { 1389 if ($map->should_reset) {
1235 $map->reset; 1390 $map->reset;
1236 undef $guard; 1391 undef $guard;
1237 $map = find_map $path 1392 $map = find $path
1238 or return; 1393 or return;
1239 } 1394 }
1240 1395
1241 $cf::MAP{$key} = $map 1396 $cf::MAP{$key} = $map
1242 } 1397 }
1264 if (aio_open $uniq, O_RDONLY, 0) { 1419 if (aio_open $uniq, O_RDONLY, 0) {
1265 $self->clear_unique_items; 1420 $self->clear_unique_items;
1266 $self->load_objects ($uniq, 0); 1421 $self->load_objects ($uniq, 0);
1267 } 1422 }
1268 } 1423 }
1424
1425 Coro::cede;
1269 1426
1270 # now do the right thing for maps 1427 # now do the right thing for maps
1271 $self->link_multipart_objects; 1428 $self->link_multipart_objects;
1272 1429
1273 if ($self->{path}->is_style_map) { 1430 if ($self->{path}->is_style_map) {
1281 $self->difficulty ($self->estimate_difficulty) 1438 $self->difficulty ($self->estimate_difficulty)
1282 unless $self->difficulty; 1439 unless $self->difficulty;
1283 $self->activate; 1440 $self->activate;
1284 } 1441 }
1285 1442
1443 Coro::cede;
1444
1286 $self->in_memory (cf::MAP_IN_MEMORY); 1445 $self->in_memory (cf::MAP_IN_MEMORY);
1287} 1446}
1288 1447
1289sub 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 {
1290 my ($path, $origin) = @_; 1473 my ($path, $origin) = @_;
1291 1474
1292 #warn "load_map_sync<$path, $origin>\n";#d# 1475 cf::sync_job { find $path, $origin }
1476}
1293 1477
1294 cf::sync_job { 1478sub do_load_sync {
1295 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
1296 or return; 1489 or next;
1490 my $path = delete $MAP_PREFETCH{$key};
1491
1492 my $map = find $path
1493 or next;
1297 $map->load; 1494 $map->load;
1298 $map 1495 }
1496 Coro::schedule;
1299 } 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 ()
1300} 1514}
1301 1515
1302sub save { 1516sub save {
1303 my ($self) = @_; 1517 my ($self) = @_;
1304 1518
1519 my $lock = cf::lock_acquire "map_data:" . $self->path;
1520
1305 $self->{last_save} = $cf::RUNTIME; 1521 $self->{last_save} = $cf::RUNTIME;
1306 1522
1307 return unless $self->dirty; 1523 return unless $self->dirty;
1308 1524
1309 my $save = $self->{path}->save_path; utf8::encode $save; 1525 my $save = $self->{path}->save_path; utf8::encode $save;
1310 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1526 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1311 1527
1312 $self->{load_path} = $save; 1528 $self->{load_path} = $save;
1313 1529
1314 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 };
1315 1537
1316 if ($uniq) { 1538 if ($uniq) {
1317 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1539 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1318 $self->save_objects ($uniq, cf::IO_UNIQUES); 1540 $self->save_objects ($uniq, cf::IO_UNIQUES);
1319 } else { 1541 } else {
1322} 1544}
1323 1545
1324sub swap_out { 1546sub swap_out {
1325 my ($self) = @_; 1547 my ($self) = @_;
1326 1548
1549 # save first because save cedes
1550 $self->save;
1551
1552 my $lock = cf::lock_acquire "map_data:" . $self->path;
1553
1327 return if $self->players; 1554 return if $self->players;
1328 return if $self->in_memory != cf::MAP_IN_MEMORY; 1555 return if $self->in_memory != cf::MAP_IN_MEMORY;
1329 return if $self->{deny_save}; 1556 return if $self->{deny_save};
1330 1557
1331 $self->save;
1332 $self->clear; 1558 $self->clear;
1333 $self->in_memory (cf::MAP_SWAPPED); 1559 $self->in_memory (cf::MAP_SWAPPED);
1334} 1560}
1335 1561
1336sub reset_at { 1562sub reset_at {
1374} 1600}
1375 1601
1376sub reset { 1602sub reset {
1377 my ($self) = @_; 1603 my ($self) = @_;
1378 1604
1605 my $lock = cf::lock_acquire "map_data:" . $self->path;
1606
1379 return if $self->players; 1607 return if $self->players;
1380 return if $self->{path}{user_rel};#d# 1608 return if $self->{path}{user_rel};#d#
1381 1609
1382 warn "resetting map ", $self->path;#d# 1610 warn "resetting map ", $self->path;#d#
1383 1611
1402 1630
1403sub customise_for { 1631sub customise_for {
1404 my ($map, $ob) = @_; 1632 my ($map, $ob) = @_;
1405 1633
1406 if ($map->per_player) { 1634 if ($map->per_player) {
1407 return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path}; 1635 return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};
1408 } 1636 }
1409 1637
1410 $map 1638 $map
1411} 1639}
1412 1640
1413sub emergency_save { 1641=item cf::map::unique_maps
1414 local $cf::FREEZE = 1;
1415 1642
1416 warn "enter emergency map save\n"; 1643Returns an arrayref of cf::path's of all shared maps that have
1644instantiated unique items. May block.
1417 1645
1418 cf::sync_job { 1646=cut
1419 warn "begin emergency map save\n"; 1647
1420 $_->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 $_;
1421 }; 1660 }
1422 1661
1423 warn "end emergency map save\n"; 1662 \@paths
1424} 1663}
1425 1664
1426package cf; 1665package cf;
1427 1666
1428=back 1667=back
1429 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
1430 1695
1431=head3 cf::object::player 1696=head3 cf::object::player
1432 1697
1433=over 4 1698=over 4
1434 1699
1509 my $link_pos = delete $self->{_link_pos}; 1774 my $link_pos = delete $self->{_link_pos};
1510 1775
1511 unless ($map) { 1776 unless ($map) {
1512 # restore original map position 1777 # restore original map position
1513 ($map, $x, $y) = @{ $link_pos || [] }; 1778 ($map, $x, $y) = @{ $link_pos || [] };
1514 $map = cf::map::find_map $map; 1779 $map = cf::map::find $map;
1515 1780
1516 unless ($map) { 1781 unless ($map) {
1517 ($map, $x, $y) = @$EMERGENCY_POSITION; 1782 ($map, $x, $y) = @$EMERGENCY_POSITION;
1518 $map = cf::map::find_map $map 1783 $map = cf::map::find $map
1519 or die "FATAL: cannot load emergency map\n"; 1784 or die "FATAL: cannot load emergency map\n";
1520 } 1785 }
1521 } 1786 }
1522 1787
1523 ($x, $y) = (-1, -1) 1788 ($x, $y) = (-1, -1)
1526 # use -1 or undef as default coordinates, not 0, 0 1791 # use -1 or undef as default coordinates, not 0, 0
1527 ($x, $y) = ($map->enter_x, $map->enter_y) 1792 ($x, $y) = ($map->enter_x, $map->enter_y)
1528 if $x <=0 && $y <= 0; 1793 if $x <=0 && $y <= 0;
1529 1794
1530 $map->load; 1795 $map->load;
1796 $map->load_diag;
1531 1797
1798 return unless $self->contr->active;
1532 $self->activate_recursive; 1799 $self->activate_recursive;
1533 $self->enter_map ($map, $x, $y); 1800 $self->enter_map ($map, $x, $y);
1534} 1801}
1535 1802
1536cf::player->attach ( 1803cf::player->attach (
1549 1816
1550 # try to abort aborted map switching on player login :) 1817 # try to abort aborted map switching on player login :)
1551 # should happen only on crashes 1818 # should happen only on crashes
1552 if ($pl->ob->{_link_pos}) { 1819 if ($pl->ob->{_link_pos}) {
1553 $pl->ob->enter_link; 1820 $pl->ob->enter_link;
1554 cf::async { 1821 (async {
1555 # 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
1556 # 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);
1557 Coro::Timer::sleep 1; 1828 Coro::Timer::sleep 1;
1558 $pl->ob->leave_link; 1829 $pl->ob->leave_link;
1559 }; 1830 })->prio (2);
1560 } 1831 }
1561 }, 1832 },
1562); 1833);
1563 1834
1564=item $player_object->goto_map ($path, $x, $y) 1835=item $player_object->goto ($path, $x, $y)
1565 1836
1566=cut 1837=cut
1567 1838
1568sub cf::object::player::goto_map { 1839sub cf::object::player::goto {
1569 my ($self, $path, $x, $y) = @_; 1840 my ($self, $path, $x, $y) = @_;
1570 1841
1842 $path = new cf::path $path;
1843
1571 $self->enter_link; 1844 $self->enter_link;
1572 1845
1573 (cf::async { 1846 (async {
1574 $path = new cf::path $path;
1575
1576 my $map = cf::map::find_map $path->as_string; 1847 my $map = cf::map::find $path->as_string;
1577 $map = $map->customise_for ($self) if $map; 1848 $map = $map->customise_for ($self) if $map;
1578 1849
1579# warn "entering ", $map->path, " at ($x, $y)\n" 1850# warn "entering ", $map->path, " at ($x, $y)\n"
1580# if $map; 1851# if $map;
1581 1852
1582 $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);
1583 1854
1584 $self->leave_link ($map, $x, $y); 1855 $self->leave_link ($map, $x, $y);
1585 })->prio (1); 1856 })->prio (1);
1586} 1857}
1587 1858
1640 1911
1641 return unless $self->type == cf::PLAYER; 1912 return unless $self->type == cf::PLAYER;
1642 1913
1643 $self->enter_link; 1914 $self->enter_link;
1644 1915
1645 (cf::async { 1916 (async {
1917 $self->deactivate_recursive; # just to be sure
1646 unless (eval { 1918 unless (eval {
1647 prepare_random_map $exit 1919 prepare_random_map $exit
1648 if $exit->slaying eq "/!"; 1920 if $exit->slaying eq "/!";
1649 1921
1650 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;
1651 $self->goto_map ($path, $exit->stats->hp, $exit->stats->sp); 1923 $self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1652 1924
1653 1; 1925 1;
1654 }) { 1926 }) {
1655 $self->message ("Something went wrong deep within the crossfire server. " 1927 $self->message ("Something went wrong deep within the crossfire server. "
1656 . "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. "
1657 . "Please report this to the dungeon master", 1929 . "Please report this to the dungeon master!",
1658 cf::NDI_UNIQUE | cf::NDI_RED); 1930 cf::NDI_UNIQUE | cf::NDI_RED);
1659 1931
1660 warn "ERROR in enter_exit: $@"; 1932 warn "ERROR in enter_exit: $@";
1661 $self->leave_link; 1933 $self->leave_link;
1662 } 1934 }
1714 my ($ns, $msg) = @_; 1986 my ($ns, $msg) = @_;
1715 1987
1716 # this weird shuffling is so that direct followup queries 1988 # this weird shuffling is so that direct followup queries
1717 # get handled first 1989 # get handled first
1718 my $queue = delete $ns->{query_queue} 1990 my $queue = delete $ns->{query_queue}
1719 or return; # be conservative, not sure how that cna happen, but we saw a crash here 1991 or return; # be conservative, not sure how that can happen, but we saw a crash here
1720 1992
1721 (shift @$queue)->[1]->($msg); 1993 (shift @$queue)->[1]->($msg);
1722 1994
1723 push @{ $ns->{query_queue} }, @$queue; 1995 push @{ $ns->{query_queue} }, @$queue;
1724 1996
1730 } 2002 }
1731 } 2003 }
1732 }, 2004 },
1733); 2005);
1734 2006
1735=item $client->coro (\&cb) 2007=item $client->async (\&cb)
1736 2008
1737Create a new coroutine, running the specified callback. The coroutine will 2009Create a new coroutine, running the specified callback. The coroutine will
1738be automatically cancelled when the client gets destroyed (e.g. on logout, 2010be automatically cancelled when the client gets destroyed (e.g. on logout,
1739or loss of connection). 2011or loss of connection).
1740 2012
1741=cut 2013=cut
1742 2014
1743sub cf::client::coro { 2015sub cf::client::async {
1744 my ($self, $cb) = @_; 2016 my ($self, $cb) = @_;
1745 2017
1746 my $coro = &cf::async ($cb); 2018 my $coro = &Coro::async ($cb);
1747 2019
1748 $coro->on_destroy (sub { 2020 $coro->on_destroy (sub {
1749 delete $self->{_coro}{$coro+0}; 2021 delete $self->{_coro}{$coro+0};
1750 }); 2022 });
1751 2023
1986 open my $fh, "<:utf8", cf::confdir . "/config" 2258 open my $fh, "<:utf8", cf::confdir . "/config"
1987 or return; 2259 or return;
1988 2260
1989 local $/; 2261 local $/;
1990 *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 }
1991} 2276}
1992 2277
1993sub main { 2278sub main {
1994 # we must not ever block the main coroutine 2279 # we must not ever block the main coroutine
1995 local $Coro::idle = sub { 2280 local $Coro::idle = sub {
1996 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#
1997 (Coro::unblock_sub {
1998 Event::one_event; 2282 async { Event::one_event };
1999 })->();
2000 }; 2283 };
2001 2284
2002 cfg_load; 2285 cfg_load;
2003 db_load; 2286 db_load;
2004 load_extensions; 2287 load_extensions;
2005 Event::loop; 2288 Event::loop;
2006} 2289}
2007 2290
2008############################################################################# 2291#############################################################################
2009# 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}
2010 2335
2011sub reload() { 2336sub reload() {
2012 # can/must only be called in main 2337 # can/must only be called in main
2013 if ($Coro::current != $Coro::main) { 2338 if ($Coro::current != $Coro::main) {
2014 warn "can only reload from main coroutine\n"; 2339 warn "can only reload from main coroutine\n";
2015 return; 2340 return;
2016 } 2341 }
2017 2342
2018 warn "reloading..."; 2343 warn "reloading...";
2019 2344
2020 local $FREEZE = 1; 2345 my $guard = freeze_mainloop;
2021 cf::emergency_save; 2346 cf::emergency_save;
2022 2347
2023 eval { 2348 eval {
2024 # 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
2025 2350
2087 cf::load_extensions; 2412 cf::load_extensions;
2088 2413
2089 # reattach attachments to objects 2414 # reattach attachments to objects
2090 warn "reattach"; 2415 warn "reattach";
2091 _global_reattach; 2416 _global_reattach;
2417 reattach $_ for values %MAP;
2092 }; 2418 };
2093 2419
2094 if ($@) { 2420 if ($@) {
2095 warn $@; 2421 warn $@;
2096 warn "error while reloading, exiting."; 2422 warn "error while reloading, exiting.";
2112 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path"; 2438 $LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2113 $LINK_MAP->in_memory (MAP_IN_MEMORY); 2439 $LINK_MAP->in_memory (MAP_IN_MEMORY);
2114 2440
2115 # dirty hack because... archetypes are not yet loaded 2441 # dirty hack because... archetypes are not yet loaded
2116 Event->timer ( 2442 Event->timer (
2117 after => 2, 2443 after => 10,
2118 cb => sub { 2444 cb => sub {
2119 $_[0]->w->cancel; 2445 $_[0]->w->cancel;
2120 2446
2121 # provide some exits "home" 2447 # provide some exits "home"
2122 my $exit = cf::object::new "exit"; 2448 my $exit = cf::object::new "exit";
2161 reentrant => 0, 2487 reentrant => 0,
2162 prio => 0, 2488 prio => 0,
2163 at => $NEXT_TICK || $TICK, 2489 at => $NEXT_TICK || $TICK,
2164 data => WF_AUTOCANCEL, 2490 data => WF_AUTOCANCEL,
2165 cb => sub { 2491 cb => sub {
2166 unless ($FREEZE) {
2167 cf::server_tick; # one server iteration 2492 cf::server_tick; # one server iteration
2168 $RUNTIME += $TICK; 2493 $RUNTIME += $TICK;
2169 }
2170
2171 $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;
2172 2498
2173 # 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
2174 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4; 2500 $NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2175 2501
2176 $TICK_WATCHER->at ($NEXT_TICK); 2502 $TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines