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.110 by root, Mon Jan 1 11:21:55 2007 UTC vs.
Revision 1.117 by root, Mon Jan 1 17:50:26 2007 UTC

… …
197=cut 197=cut
198 198
199sub sync_job(&) { 199sub sync_job(&) {
200 my ($job) = @_; 200 my ($job) = @_;
201 201
202 my $busy = 1;
203 my @res;
204
205 my $coro = Coro::async {
206 @res = eval { $job->() };
207 warn $@ if $@;
208 undef $busy;
209 };
210
211 if ($Coro::current == $Coro::main) { 202 if ($Coro::current == $Coro::main) {
203 # this is the main coro, too bad, we have to block
204 # till the operation succeeds, freezing the server :/
205
212 # TODO: use suspend/resume instead 206 # TODO: use suspend/resume instead
207 # (but this is cancel-safe)
213 local $FREEZE = 1; 208 local $FREEZE = 1;
209
210 my $busy = 1;
211 my @res;
212
213 (Coro::async {
214 @res = eval { $job->() };
215 warn $@ if $@;
216 undef $busy;
214 $coro->prio (Coro::PRIO_MAX); 217 })->prio (Coro::PRIO_MAX);
218
215 while ($busy) { 219 while ($busy) {
216 Coro::cede_notself; 220 Coro::cede_notself;
217 Event::one_event unless Coro::nready; 221 Event::one_event unless Coro::nready;
218 } 222 }
223
224 wantarray ? @res : $res[0]
219 } else { 225 } else {
220 $coro->join; 226 # we are in another coroutine, how wonderful, everything just works
227
228 $job->()
221 } 229 }
222
223 wantarray ? @res : $res[0]
224} 230}
225 231
226=item $coro = cf::coro { BLOCK } 232=item $coro = cf::coro { BLOCK }
227 233
228Creates and returns a new coro. This coro is automcatially being canceled 234Creates and returns a new coro. This coro is automcatially being canceled
… …
252 my $runtime = cf::localdir . "/runtime"; 258 my $runtime = cf::localdir . "/runtime";
253 259
254 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644 260 my $fh = aio_open "$runtime~", O_WRONLY | O_CREAT, 0644
255 or return; 261 or return;
256 262
257 my $value = $cf::RUNTIME; 263 my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
258 (aio_write $fh, 0, (length $value), $value, 0) <= 0 264 (aio_write $fh, 0, (length $value), $value, 0) <= 0
259 and return; 265 and return;
260 266
261 aio_fsync $fh 267 aio_fsync $fh
262 and return; 268 and return;
… …
283 289
284 $path = $path->as_string if ref $path; 290 $path = $path->as_string if ref $path;
285 291
286 my $self = bless { }, $class; 292 my $self = bless { }, $class;
287 293
294 # {... are special paths that are not touched
295 # ?xxx/... are special absolute paths
296 # ?random/... random maps
297 # /! non-realised random map exit
298 # /... normal maps
299 # ~/... per-player maps without a specific player (DO NOT USE)
300 # ~user/... per-player map of a specific user
301
302 if ($path =~ /^{/) {
303 # fine as it is
288 if ($path =~ s{^\?random/}{}) { 304 } elsif ($path =~ s{^\?random/}{}) {
289 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data; 305 Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
290 $self->{random} = cf::from_json $data; 306 $self->{random} = cf::from_json $data;
291 } else { 307 } else {
292 if ($path =~ s{^~([^/]+)?}{}) { 308 if ($path =~ s{^~([^/]+)?}{}) {
293 $self->{user_rel} = 1; 309 $self->{user_rel} = 1;
… …
798 or return; 814 or return;
799 815
800 unless (aio_stat "$filename.pst") { 816 unless (aio_stat "$filename.pst") {
801 (aio_load "$filename.pst", $av) >= 0 817 (aio_load "$filename.pst", $av) >= 0
802 or return; 818 or return;
803 $av = eval { (Storable::thaw <$av>)->{objs} }; 819 $av = eval { (Storable::thaw $av)->{objs} };
804 } 820 }
805 821
806 return ($data, $av); 822 return ($data, $av);
807} 823}
808 824
… …
1046use Fcntl; 1062use Fcntl;
1047use Coro::AIO; 1063use Coro::AIO;
1048 1064
1049our $MAX_RESET = 7200; 1065our $MAX_RESET = 7200;
1050our $DEFAULT_RESET = 3600; 1066our $DEFAULT_RESET = 3600;
1051$MAX_RESET = 10;#d#
1052$DEFAULT_RESET = 10;#d#
1053 1067
1054sub generate_random_map { 1068sub generate_random_map {
1055 my ($path, $rmp) = @_; 1069 my ($path, $rmp) = @_;
1056 1070
1057 # mit "rum" bekleckern, nicht 1071 # mit "rum" bekleckern, nicht
… …
1090 1104
1091 $map->load_header ($path) 1105 $map->load_header ($path)
1092 or return; 1106 or return;
1093 1107
1094 $map->{load_path} = $path; 1108 $map->{load_path} = $path;
1095 use Data::Dumper; warn Dumper $map;#d#
1096 1109
1097 $map 1110 $map
1098} 1111}
1099 1112
1100sub find_map { 1113sub find_map {
1101 my ($path, $origin) = @_; 1114 my ($path, $origin) = @_;
1102 1115
1103 #warn "find_map<$path,$origin>\n";#d# 1116 #warn "find_map<$path,$origin>\n";#d#
1104 1117
1105 $path = ref $path ? $path : new cf::path $path, $origin && $origin->path; 1118 $path = new cf::path $path, $origin && $origin->path;
1106 my $key = $path->as_string; 1119 my $key = $path->as_string;
1107 1120
1108 $cf::MAP{$key} || do { 1121 $cf::MAP{$key} || do {
1109 # do it the slow way 1122 # do it the slow way
1110 my $map = try_load_header $path->save_path; 1123 my $map = try_load_header $path->save_path;
… …
1120 $map = try_load_header $path->load_path; 1133 $map = try_load_header $path->load_path;
1121 } 1134 }
1122 1135
1123 $map or return; 1136 $map or return;
1124 1137
1138 $map->{load_original} = 1;
1125 $map->{instantiate_time} = $cf::RUNTIME; 1139 $map->{instantiate_time} = $cf::RUNTIME;
1126 $map->instantiate; 1140 $map->instantiate;
1127 1141
1128 # per-player maps become, after loading, normal maps 1142 # per-player maps become, after loading, normal maps
1129 $map->per_player (0) if $path->{user_rel}; 1143 $map->per_player (0) if $path->{user_rel};
1130 } 1144 }
1131 1145
1132 $map->path ($key); 1146 $map->path ($key);
1133 $map->{path} = $path; 1147 $map->{path} = $path;
1148 $map->{last_save} = $cf::RUNTIME;
1134 $map->last_access ($cf::RUNTIME); 1149 $map->last_access ($cf::RUNTIME);
1135 1150
1136 $map->reset if $map->should_reset; 1151 if ($map->should_reset) {
1152 $map->reset;
1153 $map = find_map $path;
1154 }
1137 1155
1138 $cf::MAP{$key} = $map 1156 $cf::MAP{$key} = $map
1139 } 1157 }
1140} 1158}
1141 1159
… …
1149 my $path = $self->{path}; 1167 my $path = $self->{path};
1150 1168
1151 $self->alloc; 1169 $self->alloc;
1152 $self->load_objects ($self->{load_path}, 1) 1170 $self->load_objects ($self->{load_path}, 1)
1153 or return; 1171 or return;
1172
1173 $self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1174 if delete $self->{load_original};
1154 1175
1155 if (my $uniq = $path->uniq_path) { 1176 if (my $uniq = $path->uniq_path) {
1156 utf8::encode $uniq; 1177 utf8::encode $uniq;
1157 if (aio_open $uniq, O_RDONLY, 0) { 1178 if (aio_open $uniq, O_RDONLY, 0) {
1158 $self->clear_unique_items; 1179 $self->clear_unique_items;
… …
1193} 1214}
1194 1215
1195sub save { 1216sub save {
1196 my ($self) = @_; 1217 my ($self) = @_;
1197 1218
1219 $self->{last_save} = $cf::RUNTIME;
1220
1221 return unless $self->dirty;
1222
1198 my $save = $self->{path}->save_path; utf8::encode $save; 1223 my $save = $self->{path}->save_path; utf8::encode $save;
1199 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq; 1224 my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
1200 1225
1201 $self->{last_save} = $cf::RUNTIME;
1202
1203 return unless $self->dirty;
1204
1205 $self->{load_path} = $save; 1226 $self->{load_path} = $save;
1206 1227
1207 return if $self->{deny_save}; 1228 return if $self->{deny_save};
1208
1209 warn "saving map ", $self->path;
1210 1229
1211 if ($uniq) { 1230 if ($uniq) {
1212 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS); 1231 $self->save_objects ($save, cf::IO_HEADER | cf::IO_OBJECTS);
1213 $self->save_objects ($uniq, cf::IO_UNIQUES); 1232 $self->save_objects ($uniq, cf::IO_UNIQUES);
1214 } else { 1233 } else {
… …
1226 $self->save; 1245 $self->save;
1227 $self->clear; 1246 $self->clear;
1228 $self->in_memory (cf::MAP_SWAPPED); 1247 $self->in_memory (cf::MAP_SWAPPED);
1229} 1248}
1230 1249
1250sub reset_at {
1251 my ($self) = @_;
1252
1253 # TODO: safety, remove and allow resettable per-player maps
1254 return 1e99 if $self->{path}{user_rel};
1255 return 1e99 if $self->{deny_reset};
1256
1257 my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1258 my $to = List::Util::min $MAX_RESET, $self->reset_timeout || $DEFAULT_RESET;
1259
1260 $time + $to
1261}
1262
1231sub should_reset { 1263sub should_reset {
1232 my ($map) = @_;
1233
1234 # TODO: safety, remove and allow resettable per-player maps
1235 return if $map->{path}{user_rel};#d#
1236 return if $map->{deny_reset};
1237 #return unless $map->reset_timeout;
1238
1239 my $time = $map->fixed_resettime ? $map->{instantiate_time} : $map->last_access;
1240
1241 $time + ($map->reset_timeout || $DEFAULT_RESET) < $cf::RUNTIME
1242}
1243
1244sub reset {
1245 my ($self) = @_; 1264 my ($self) = @_;
1246 1265
1247 return if $self->players; 1266 $self->reset_at <= $cf::RUNTIME
1248 return if $self->{path}{user_rel};#d# 1267}
1249 1268
1250 warn "resetting map ", $self->path;#d# 1269sub unlink_save {
1270 my ($self) = @_;
1251 1271
1252 utf8::encode (my $save = $self->{path}->save_path); 1272 utf8::encode (my $save = $self->{path}->save_path);
1253 aioreq_pri 3; IO::AIO::aio_unlink $save; 1273 aioreq_pri 3; IO::AIO::aio_unlink $save;
1254 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst"; 1274 aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1275}
1276
1277sub rename {
1278 my ($self, $new_path) = @_;
1279
1280 $self->unlink_save;
1281
1282 delete $cf::MAP{$self->path};
1283 $self->{path} = new cf::path $new_path;
1284 $self->path ($self->{path}->as_string);
1285 $cf::MAP{$self->path} = $self;
1286
1287 $self->save;
1288}
1289
1290sub reset {
1291 my ($self) = @_;
1292
1293 return if $self->players;
1294 return if $self->{path}{user_rel};#d#
1295
1296 warn "resetting map ", $self->path;#d#
1297
1298 delete $cf::MAP{$self->path};
1255 1299
1256 $_->clear_links_to ($self) for values %cf::MAP; 1300 $_->clear_links_to ($self) for values %cf::MAP;
1257 1301
1302 $self->unlink_save;
1258 $self->clear; 1303 $self->destroy;
1259 $self->in_memory (cf::MAP_SWAPPED); 1304}
1260 utf8::encode ($self->{load_path} = $self->{path}->load_path); 1305
1306my $nuke_counter = "aaaa";
1307
1308sub nuke {
1309 my ($self) = @_;
1310
1311 $self->{deny_save} = 1;
1312 $self->reset_timeout (1);
1313 $self->rename ("{nuke}/" . ($nuke_counter++));
1314 $self->reset; # polite request, might not happen
1261} 1315}
1262 1316
1263sub customise_for { 1317sub customise_for {
1264 my ($map, $ob) = @_; 1318 my ($map, $ob) = @_;
1265 1319
… …
1330 (ref $cf::CFG{"may_$access"} 1384 (ref $cf::CFG{"may_$access"}
1331 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}} 1385 ? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1332 : $cf::CFG{"may_$access"}) 1386 : $cf::CFG{"may_$access"})
1333} 1387}
1334 1388
1389=item $player_object->enter_link
1390
1391Freezes the player and moves him/her to a special map (C<{link}>).
1392
1393The player should be reaosnably safe there for short amounts of time. You
1394I<MUST> call C<leave_link> as soon as possible, though.
1395
1396=item $player_object->leave_link ($map, $x, $y)
1397
1398Moves the player out of the specila link map onto the given map. If the
1399map is not valid (or omitted), the player will be moved back to the
1400location he/she was before the call to C<enter_link>, or, if that fails,
1401to the emergency map position.
1402
1403Might block.
1404
1405=cut
1406
1335sub cf::object::player::enter_link { 1407sub cf::object::player::enter_link {
1336 my ($self) = @_; 1408 my ($self) = @_;
1337 1409
1338 return if $self->map == $LINK_MAP; 1410 return if $self->map == $LINK_MAP;
1339 1411
… …
1348 my ($self, $map, $x, $y) = @_; 1420 my ($self, $map, $x, $y) = @_;
1349 1421
1350 my $link_pos = delete $self->{_link_pos}; 1422 my $link_pos = delete $self->{_link_pos};
1351 1423
1352 unless ($map) { 1424 unless ($map) {
1353 $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1354
1355 # restore original map position 1425 # restore original map position
1356 ($map, $x, $y) = @{ $link_pos || [] }; 1426 ($map, $x, $y) = @{ $link_pos || [] };
1357 $map = cf::map::find_map $map; 1427 $map = cf::map::find_map $map;
1358 1428
1359 unless ($map) { 1429 unless ($map) {
… …
1391 my $map = cf::map::find_map $path->as_string; 1461 my $map = cf::map::find_map $path->as_string;
1392 $map = $map->customise_for ($self) if $map; 1462 $map = $map->customise_for ($self) if $map;
1393 1463
1394 warn "entering ", $map->path, " at ($x, $y)\n" 1464 warn "entering ", $map->path, " at ($x, $y)\n"
1395 if $map; 1465 if $map;
1466
1467 $map or $self->message ("The exit is closed", cf::NDI_UNIQUE | cf::NDI_RED);
1396 1468
1397 $self->leave_link ($map, $x, $y); 1469 $self->leave_link ($map, $x, $y);
1398 })->prio (1); 1470 })->prio (1);
1399} 1471}
1400 1472
… …
1811} 1883}
1812 1884
1813sub main { 1885sub main {
1814 # we must not ever block the main coroutine 1886 # we must not ever block the main coroutine
1815 local $Coro::idle = sub { 1887 local $Coro::idle = sub {
1816 Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d# 1888 Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1817 (Coro::unblock_sub { 1889 (Coro::unblock_sub {
1818 Event::one_event; 1890 Event::one_event;
1819 })->(); 1891 })->();
1820 }; 1892 };
1821 1893
… …
1826} 1898}
1827 1899
1828############################################################################# 1900#############################################################################
1829# initialisation 1901# initialisation
1830 1902
1831sub perl_reload() { 1903sub reload() {
1832 # can/must only be called in main 1904 # can/must only be called in main
1833 if ($Coro::current != $Coro::main) { 1905 if ($Coro::current != $Coro::main) {
1834 warn "can only reload from main coroutine\n"; 1906 warn "can only reload from main coroutine\n";
1835 return; 1907 return;
1836 } 1908 }
… …
1963 $cf::MAP{$LINK_MAP->path} = $LINK_MAP; 2035 $cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1964} 2036}
1965 2037
1966register "<global>", __PACKAGE__; 2038register "<global>", __PACKAGE__;
1967 2039
1968register_command "perl-reload" => sub { 2040register_command "reload" => sub {
1969 my ($who, $arg) = @_; 2041 my ($who, $arg) = @_;
1970 2042
1971 if ($who->flag (FLAG_WIZ)) { 2043 if ($who->flag (FLAG_WIZ)) {
1972 $who->message ("start of reload."); 2044 $who->message ("start of reload.");
1973 perl_reload; 2045 reload;
1974 $who->message ("end of reload."); 2046 $who->message ("end of reload.");
1975 } 2047 }
1976}; 2048};
1977 2049
1978unshift @INC, $LIBDIR; 2050unshift @INC, $LIBDIR;

Diff Legend

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