[ViewVC] Diff of: cvs/deliantra/server/lib/cf.pm

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.109 by root, Sun Dec 31 22:23:12 2006 UTC vs.
Revision 1.131 by root, Thu Jan 4 00:53:54 2007 UTC

…		…
8	use Storable;	8	use Storable;
9	use Opcode;	9	use Opcode;
10	use Safe;	10	use Safe;
11	use Safe::Hole;	11	use Safe::Hole;
12		12
13	use Coro 3.3;	13	use Coro 3.3 ();
14	use Coro::Event;	14	use Coro::Event;
15	use Coro::Timer;	15	use Coro::Timer;
16	use Coro::Signal;	16	use Coro::Signal;
17	use Coro::Semaphore;	17	use Coro::Semaphore;
18	use Coro::AIO;	18	use Coro::AIO;
…		…
71	mkdir cf::localdir . "/" . cf::uniquedir;	71	mkdir cf::localdir . "/" . cf::uniquedir;
72	mkdir $RANDOM_MAPS;	72	mkdir $RANDOM_MAPS;
73		73
74	# a special map that is always available	74	# a special map that is always available
75	our $LINK_MAP;	75	our $LINK_MAP;
		76	our $EMERGENCY_POSITION;
76		77
77	#############################################################################	78	#############################################################################
78		79
79	=head2 GLOBAL VARIABLES	80	=head2 GLOBAL VARIABLES
80		81
…		…
179	sub to_json($) {	180	sub to_json($) {
180	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	181	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
181	JSON::Syck::Dump $_[0]	182	JSON::Syck::Dump $_[0]
182	}	183	}
183		184
		185	=item my $guard = cf::guard { BLOCK }
		186
		187	Run the given callback when the guard object gets destroyed (useful for
		188	coroutine cancellations).
		189
		190	You can call C<< ->cancel >> on the guard object to stop the block from
		191	being executed.
		192
		193	=cut
		194
		195	sub guard(&) {
		196	bless \(my $cb = $_[0]), cf::guard::;
		197	}
		198
		199	sub cf::guard::cancel {
		200	${$_[0]} = sub { };
		201	}
		202
		203	sub cf::guard::DESTROY {
		204	${$_[0]}->();
		205	}
		206
		207	=item cf::lock_wait $string
		208
		209	Wait until the given lock is available. See cf::lock_acquire.
		210
		211	=item my $lock = cf::lock_acquire $string
		212
		213	Wait until the given lock is available and then acquires it and returns
		214	a guard object. If the guard object gets destroyed (goes out of scope,
		215	for example when the coroutine gets canceled), the lock is automatically
		216	returned.
		217
		218	Lock names should begin with a unique identifier (for example, find_map
		219	uses map_find and load_map uses map_load).
		220
		221	=cut
		222
		223	our %LOCK;
		224
		225	sub lock_wait($) {
		226	my ($key) = @_;
		227
		228	# wait for lock, if any
		229	while ($LOCK{$key}) {
		230	push @{ $LOCK{$key} }, $Coro::current;
		231	Coro::schedule;
		232	}
		233	}
		234
		235	sub lock_acquire($) {
		236	my ($key) = @_;
		237
		238	# wait, to be sure we are not locked
		239	lock_wait $key;
		240
		241	$LOCK{$key} = [];
		242
		243	cf::guard {
		244	# wake up all waiters, to be on the safe side
		245	$_->ready for @{ delete $LOCK{$key} };
		246	}
		247	}
		248
		249	=item cf::async { BLOCK }
		250
		251	Like C<Coro::async>, but runs the given BLOCK in an eval and only logs the
		252	error instead of exiting the server in case of a problem.
		253
		254	=cut
		255
		256	sub async(&) {
		257	my ($cb) = @_;
		258
		259	Coro::async {
		260	eval { $cb->() };
		261	warn $@ if $@;
		262	}
		263	}
		264
184	=item cf::sync_job { BLOCK }	265	=item cf::sync_job { BLOCK }
185		266
186	The design of crossfire+ requires that the main coro ($Coro::main) is	267	The design of crossfire+ requires that the main coro ($Coro::main) is
187	always able to handle events or runnable, as crossfire+ is only partly	268	always able to handle events or runnable, as crossfire+ is only partly
188	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.	269	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
…		…
195	=cut	276	=cut
196		277
197	sub sync_job(&) {	278	sub sync_job(&) {
198	my ($job) = @_;	279	my ($job) = @_;
199		280
200	my $busy = 1;
201	my @res;
202
203	# TODO: use suspend/resume instead
204	local $FREEZE = 1;
205
206	my $coro = Coro::async {
207	@res = eval { $job->() };
208	warn $@ if $@;
209	undef $busy;
210	};
211
212	if ($Coro::current == $Coro::main) {	281	if ($Coro::current == $Coro::main) {
		282	# this is the main coro, too bad, we have to block
		283	# till the operation succeeds, freezing the server :/
		284
		285	# TODO: use suspend/resume instead
		286	# (but this is cancel-safe)
		287	local $FREEZE = 1;
		288
		289	my $busy = 1;
		290	my @res;
		291
		292	(Coro::async {
		293	@res = eval { $job->() };
		294	warn $@ if $@;
		295	undef $busy;
213	$coro->prio (Coro::PRIO_MAX);	296	})->prio (Coro::PRIO_MAX);
		297
214	while ($busy) {	298	while ($busy) {
215	Coro::cede_notself;	299	Coro::cede_notself;
216	Event::one_event unless Coro::nready;	300	Event::one_event unless Coro::nready;
217	}	301	}
		302
		303	wantarray ? @res : $res[0]
218	} else {	304	} else {
219	$coro->join;	305	# we are in another coroutine, how wonderful, everything just works
		306
		307	$job->()
220	}	308	}
221
222	wantarray ? @res : $res[0]
223	}	309	}
224		310
225	=item $coro = cf::coro { BLOCK }	311	=item $coro = cf::coro { BLOCK }
226		312
227	Creates and returns a new coro. This coro is automcatially being canceled	313	Creates and returns a new coro. This coro is automcatially being canceled
…		…
230	=cut	316	=cut
231		317
232	sub coro(&) {	318	sub coro(&) {
233	my $cb = shift;	319	my $cb = shift;
234		320
235	my $coro; $coro = async {	321	my $coro = &cf::async ($cb);
236	eval {
237	$cb->();
238	};
239	warn $@ if $@;
240	};
241		322
242	$coro->on_destroy (sub {	323	$coro->on_destroy (sub {
243	delete $EXT_CORO{$coro+0};	324	delete $EXT_CORO{$coro+0};
244	});	325	});
245	$EXT_CORO{$coro+0} = $coro;	326	$EXT_CORO{$coro+0} = $coro;
…		…
251	my $runtime = cf::localdir . "/runtime";	332	my $runtime = cf::localdir . "/runtime";
252		333
253	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644	334	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644
254	or return;	335	or return;
255		336
256	my $value = $cf::RUNTIME;	337	my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
257	(aio_write $fh, 0, (length $value), $value, 0) <= 0	338	(aio_write $fh, 0, (length $value), $value, 0) <= 0
258	and return;	339	and return;
259		340
260	aio_fsync $fh	341	aio_fsync $fh
261	and return;	342	and return;
…		…
278	package cf::path;	359	package cf::path;
279		360
280	sub new {	361	sub new {
281	my ($class, $path, $base) = @_;	362	my ($class, $path, $base) = @_;
282		363
		364	$path = $path->as_string if ref $path;
		365
283	my $self = bless { }, $class;	366	my $self = bless { }, $class;
284		367
		368	# {... are special paths that are not touched
		369	# ?xxx/... are special absolute paths
		370	# ?random/... random maps
		371	# /! non-realised random map exit
		372	# /... normal maps
		373	# ~/... per-player maps without a specific player (DO NOT USE)
		374	# ~user/... per-player map of a specific user
		375
		376	if ($path =~ /^{/) {
		377	# fine as it is
285	if ($path =~ s{^\?random/}{}) {	378	} elsif ($path =~ s{^\?random/}{}) {
286	Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;	379	Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
287	$self->{random} = cf::from_json $data;	380	$self->{random} = cf::from_json $data;
288	} else {	381	} else {
289	if ($path =~ s{^~([^/]+)?}{}) {	382	if ($path =~ s{^~([^/]+)?}{}) {
290	$self->{user_rel} = 1;	383	$self->{user_rel} = 1;
…		…
795	or return;	888	or return;
796		889
797	unless (aio_stat "$filename.pst") {	890	unless (aio_stat "$filename.pst") {
798	(aio_load "$filename.pst", $av) >= 0	891	(aio_load "$filename.pst", $av) >= 0
799	or return;	892	or return;
800	$av = eval { (Storable::thaw <$av>)->{objs} };	893	$av = eval { (Storable::thaw $av)->{objs} };
801	}	894	}
802		895
		896	warn sprintf "loading %s (%d)\n",
		897	$filename, length $data, scalar @{$av \|\| []};#d#
803	return ($data, $av);	898	return ($data, $av);
804	}	899	}
805		900
806	#############################################################################	901	#############################################################################
807	# command handling &c	902	# command handling &c
…		…
1029	$self->send ("ext " . to_json \%msg);	1124	$self->send ("ext " . to_json \%msg);
1030	}	1125	}
1031		1126
1032	=back	1127	=back
1033		1128
		1129
		1130	=head3 cf::map
		1131
		1132	=over 4
		1133
		1134	=cut
		1135
		1136	package cf::map;
		1137
		1138	use Fcntl;
		1139	use Coro::AIO;
		1140
		1141	our $MAX_RESET = 7200;
		1142	our $DEFAULT_RESET = 3600;
		1143
		1144	sub generate_random_map {
		1145	my ($path, $rmp) = @_;
		1146
		1147	# mit "rum" bekleckern, nicht
		1148	cf::map::_create_random_map
		1149	$path,
		1150	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
		1151	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
		1152	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
		1153	$rmp->{exit_on_final_map},
		1154	$rmp->{xsize}, $rmp->{ysize},
		1155	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
		1156	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
		1157	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
		1158	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
		1159	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
		1160	(cf::region::find $rmp->{region})
		1161	}
		1162
		1163	# and all this just because we cannot iterate over
		1164	# all maps in C++...
		1165	sub change_all_map_light {
		1166	my ($change) = @_;
		1167
		1168	$_->change_map_light ($change)
		1169	for grep $_->outdoor, values %cf::MAP;
		1170	}
		1171
		1172	sub try_load_header($) {
		1173	my ($path) = @_;
		1174
		1175	utf8::encode $path;
		1176	aio_open $path, O_RDONLY, 0
		1177	or return;
		1178
		1179	my $map = cf::map::new
		1180	or return;
		1181
		1182	$map->load_header ($path)
		1183	or return;
		1184
		1185	$map->{load_path} = $path;
		1186
		1187	$map
		1188	}
		1189
		1190	sub find_map;
		1191	sub find_map {
		1192	my ($path, $origin) = @_;
		1193
		1194	#warn "find_map<$path,$origin>\n";#d#
		1195
		1196	$path = new cf::path $path, $origin && $origin->path;
		1197	my $key = $path->as_string;
		1198
		1199	cf::lock_wait "map_find:$key";
		1200
		1201	$cf::MAP{$key} \|\| do {
		1202	my $guard = cf::lock_acquire "map_find:$key";
		1203
		1204	# do it the slow way
		1205	my $map = try_load_header $path->save_path;
		1206
		1207	if ($map) {
		1208	# safety
		1209	$map->{instantiate_time} = $cf::RUNTIME
		1210	if $map->{instantiate_time} > $cf::RUNTIME;
		1211	} else {
		1212	if (my $rmp = $path->random_map_params) {
		1213	$map = generate_random_map $key, $rmp;
		1214	} else {
		1215	$map = try_load_header $path->load_path;
		1216	}
		1217
		1218	$map or return;
		1219
		1220	$map->{load_original} = 1;
		1221	$map->{instantiate_time} = $cf::RUNTIME;
		1222	$map->instantiate;
		1223
		1224	# per-player maps become, after loading, normal maps
		1225	$map->per_player (0) if $path->{user_rel};
		1226	}
		1227
		1228	$map->path ($key);
		1229	$map->{path} = $path;
		1230	$map->{last_save} = $cf::RUNTIME;
		1231	$map->last_access ($cf::RUNTIME);
		1232
		1233	if ($map->should_reset) {
		1234	$map->reset;
		1235	undef $guard;
		1236	$map = find_map $path
		1237	or return;
		1238	}
		1239
		1240	$cf::MAP{$key} = $map
		1241	}
		1242	}
		1243
		1244	sub load {
		1245	my ($self) = @_;
		1246
		1247	my $path = $self->{path};
		1248	my $guard = cf::lock_acquire "map_load:" . $path->as_string;
		1249
		1250	return if $self->in_memory != cf::MAP_SWAPPED;
		1251
		1252	$self->in_memory (cf::MAP_LOADING);
		1253
		1254	$self->alloc;
		1255	$self->load_objects ($self->{load_path}, 1)
		1256	or return;
		1257
		1258	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
		1259	if delete $self->{load_original};
		1260
		1261	if (my $uniq = $path->uniq_path) {
		1262	utf8::encode $uniq;
		1263	if (aio_open $uniq, O_RDONLY, 0) {
		1264	$self->clear_unique_items;
		1265	$self->load_objects ($uniq, 0);
		1266	}
		1267	}
		1268
		1269	# now do the right thing for maps
		1270	$self->link_multipart_objects;
		1271
		1272	if ($self->{path}->is_style_map) {
		1273	$self->{deny_save} = 1;
		1274	$self->{deny_reset} = 1;
		1275	} else {
		1276	$self->fix_auto_apply;
		1277	$self->decay_objects;
		1278	$self->update_buttons;
		1279	$self->set_darkness_map;
		1280	$self->difficulty ($self->estimate_difficulty)
		1281	unless $self->difficulty;
		1282	$self->activate;
		1283	}
		1284
		1285	$self->in_memory (cf::MAP_IN_MEMORY);
		1286	}
		1287
		1288	sub load_map_sync {
		1289	my ($path, $origin) = @_;
		1290
		1291	#warn "load_map_sync<$path, $origin>\n";#d#
		1292
		1293	cf::sync_job {
		1294	my $map = cf::map::find_map $path, $origin
		1295	or return;
		1296	$map->load;
		1297	$map
		1298	}
		1299	}
		1300
		1301	sub save {
		1302	my ($self) = @_;
		1303
		1304	$self->{last_save} = $cf::RUNTIME;
		1305
		1306	return unless $self->dirty;
		1307
		1308	my $save = $self->{path}->save_path; utf8::encode $save;
		1309	my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
		1310
		1311	$self->{load_path} = $save;
		1312
		1313	return if $self->{deny_save};
		1314
		1315	if ($uniq) {
		1316	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
		1317	$self->save_objects ($uniq, cf::IO_UNIQUES);
		1318	} else {
		1319	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);
		1320	}
		1321	}
		1322
		1323	sub swap_out {
		1324	my ($self) = @_;
		1325
		1326	# save first because save cedes
		1327	$self->save;
		1328
		1329	return if $self->players;
		1330	return if $self->in_memory != cf::MAP_IN_MEMORY;
		1331	return if $self->{deny_save};
		1332
		1333	$self->clear;
		1334	$self->in_memory (cf::MAP_SWAPPED);
		1335	}
		1336
		1337	sub reset_at {
		1338	my ($self) = @_;
		1339
		1340	# TODO: safety, remove and allow resettable per-player maps
		1341	return 1e99 if $self->{path}{user_rel};
		1342	return 1e99 if $self->{deny_reset};
		1343
		1344	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		1345	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
		1346
		1347	$time + $to
		1348	}
		1349
		1350	sub should_reset {
		1351	my ($self) = @_;
		1352
		1353	$self->reset_at <= $cf::RUNTIME
		1354	}
		1355
		1356	sub unlink_save {
		1357	my ($self) = @_;
		1358
		1359	utf8::encode (my $save = $self->{path}->save_path);
		1360	aioreq_pri 3; IO::AIO::aio_unlink $save;
		1361	aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
		1362	}
		1363
		1364	sub rename {
		1365	my ($self, $new_path) = @_;
		1366
		1367	$self->unlink_save;
		1368
		1369	delete $cf::MAP{$self->path};
		1370	$self->{path} = new cf::path $new_path;
		1371	$self->path ($self->{path}->as_string);
		1372	$cf::MAP{$self->path} = $self;
		1373
		1374	$self->save;
		1375	}
		1376
		1377	sub reset {
		1378	my ($self) = @_;
		1379
		1380	return if $self->players;
		1381	return if $self->{path}{user_rel};#d#
		1382
		1383	warn "resetting map ", $self->path;#d#
		1384
		1385	delete $cf::MAP{$self->path};
		1386
		1387	$_->clear_links_to ($self) for values %cf::MAP;
		1388
		1389	$self->unlink_save;
		1390	$self->destroy;
		1391	}
		1392
		1393	my $nuke_counter = "aaaa";
		1394
		1395	sub nuke {
		1396	my ($self) = @_;
		1397
		1398	$self->{deny_save} = 1;
		1399	$self->reset_timeout (1);
		1400	$self->rename ("{nuke}/" . ($nuke_counter++));
		1401	$self->reset; # polite request, might not happen
		1402	}
		1403
		1404	sub customise_for {
		1405	my ($map, $ob) = @_;
		1406
		1407	if ($map->per_player) {
		1408	return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path};
		1409	}
		1410
		1411	$map
		1412	}
		1413
		1414	sub emergency_save {
		1415	local $cf::FREEZE = 1;
		1416
		1417	warn "enter emergency map save\n";
		1418
		1419	cf::sync_job {
		1420	warn "begin emergency map save\n";
		1421	$_->save for values %cf::MAP;
		1422	};
		1423
		1424	warn "end emergency map save\n";
		1425	}
		1426
		1427	package cf;
		1428
		1429	=back
		1430
		1431
1034	=head3 cf::object::player	1432	=head3 cf::object::player
1035		1433
1036	=over 4	1434	=over 4
1037		1435
1038	=item $player_object->reply ($npc, $msg[, $flags])	1436	=item $player_object->reply ($npc, $msg[, $flags])
…		…
1073	(ref $cf::CFG{"may_$access"}	1471	(ref $cf::CFG{"may_$access"}
1074	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	1472	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1075	: $cf::CFG{"may_$access"})	1473	: $cf::CFG{"may_$access"})
1076	}	1474	}
1077		1475
		1476	=item $player_object->enter_link
		1477
		1478	Freezes the player and moves him/her to a special map (C<{link}>).
		1479
		1480	The player should be reaosnably safe there for short amounts of time. You
		1481	I<MUST> call C<leave_link> as soon as possible, though.
		1482
		1483	=item $player_object->leave_link ($map, $x, $y)
		1484
		1485	Moves the player out of the specila link map onto the given map. If the
		1486	map is not valid (or omitted), the player will be moved back to the
		1487	location he/she was before the call to C<enter_link>, or, if that fails,
		1488	to the emergency map position.
		1489
		1490	Might block.
		1491
		1492	=cut
		1493
		1494	sub cf::object::player::enter_link {
		1495	my ($self) = @_;
		1496
		1497	$self->deactivate_recursive;
		1498
		1499	return if $self->map == $LINK_MAP;
		1500
		1501	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]
		1502	if $self->map;
		1503
		1504	$self->enter_map ($LINK_MAP, 20, 20);
		1505	}
		1506
		1507	sub cf::object::player::leave_link {
		1508	my ($self, $map, $x, $y) = @_;
		1509
		1510	my $link_pos = delete $self->{_link_pos};
		1511
		1512	unless ($map) {
		1513	# restore original map position
		1514	($map, $x, $y) = @{ $link_pos \|\| [] };
		1515	$map = cf::map::find_map $map;
		1516
		1517	unless ($map) {
		1518	($map, $x, $y) = @$EMERGENCY_POSITION;
		1519	$map = cf::map::find_map $map
		1520	or die "FATAL: cannot load emergency map\n";
		1521	}
		1522	}
		1523
		1524	($x, $y) = (-1, -1)
		1525	unless (defined $x) && (defined $y);
		1526
		1527	# use -1 or undef as default coordinates, not 0, 0
		1528	($x, $y) = ($map->enter_x, $map->enter_y)
		1529	if $x <=0 && $y <= 0;
		1530
		1531	$map->load;
		1532
		1533	$self->activate_recursive;
		1534	$self->enter_map ($map, $x, $y);
		1535	}
		1536
		1537	cf::player->attach (
		1538	on_logout => sub {
		1539	my ($pl) = @_;
		1540
		1541	# abort map switching before logout
		1542	if ($pl->ob->{_link_pos}) {
		1543	cf::sync_job {
		1544	$pl->ob->leave_link
		1545	};
		1546	}
		1547	},
		1548	on_login => sub {
		1549	my ($pl) = @_;
		1550
		1551	# try to abort aborted map switching on player login :)
		1552	# should happen only on crashes
		1553	if ($pl->ob->{_link_pos}) {
		1554	$pl->ob->enter_link;
		1555	cf::async {
		1556	# we need this sleep as the login has a concurrent enter_exit running
		1557	# and this sleep increases chances of the player not ending up in scorn
		1558	Coro::Timer::sleep 1;
		1559	$pl->ob->leave_link;
		1560	};
		1561	}
		1562	},
		1563	);
		1564
		1565	=item $player_object->goto_map ($path, $x, $y)
		1566
		1567	=cut
		1568
		1569	sub cf::object::player::goto_map {
		1570	my ($self, $path, $x, $y) = @_;
		1571
		1572	$self->enter_link;
		1573
		1574	(cf::async {
		1575	$path = new cf::path $path;
		1576
		1577	my $map = cf::map::find_map $path->as_string;
		1578	$map = $map->customise_for ($self) if $map;
		1579
		1580	# warn "entering ", $map->path, " at ($x, $y)\n"
		1581	# if $map;
		1582
		1583	$map or $self->message ("The exit is closed", cf::NDI_UNIQUE \| cf::NDI_RED);
		1584
		1585	$self->leave_link ($map, $x, $y);
		1586	})->prio (1);
		1587	}
		1588
		1589	=item $player_object->enter_exit ($exit_object)
		1590
		1591	=cut
		1592
		1593	sub parse_random_map_params {
		1594	my ($spec) = @_;
		1595
		1596	my $rmp = { # defaults
		1597	xsize => 10,
		1598	ysize => 10,
		1599	};
		1600
		1601	for (split /\n/, $spec) {
		1602	my ($k, $v) = split /\s+/, $_, 2;
		1603
		1604	$rmp->{lc $k} = $v if (length $k) && (length $v);
		1605	}
		1606
		1607	$rmp
		1608	}
		1609
		1610	sub prepare_random_map {
		1611	my ($exit) = @_;
		1612
		1613	# all this does is basically replace the /! path by
		1614	# a new random map path (?random/...) with a seed
		1615	# that depends on the exit object
		1616
		1617	my $rmp = parse_random_map_params $exit->msg;
		1618
		1619	if ($exit->map) {
		1620	$rmp->{region} = $exit->map->region_name;
		1621	$rmp->{origin_map} = $exit->map->path;
		1622	$rmp->{origin_x} = $exit->x;
		1623	$rmp->{origin_y} = $exit->y;
		1624	}
		1625
		1626	$rmp->{random_seed} \|\|= $exit->random_seed;
		1627
		1628	my $data = cf::to_json $rmp;
		1629	my $md5 = Digest::MD5::md5_hex $data;
		1630
		1631	if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY \| O_CREAT, 0666) {
		1632	aio_write $fh, 0, (length $data), $data, 0;
		1633
		1634	$exit->slaying ("?random/$md5");
		1635	$exit->msg (undef);
		1636	}
		1637	}
		1638
		1639	sub cf::object::player::enter_exit {
		1640	my ($self, $exit) = @_;
		1641
		1642	return unless $self->type == cf::PLAYER;
		1643
		1644	$self->enter_link;
		1645
		1646	(cf::async {
		1647	unless (eval {
		1648	prepare_random_map $exit
		1649	if $exit->slaying eq "/!";
		1650
		1651	my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
		1652	$self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
		1653
		1654	1;
		1655	}) {
		1656	$self->message ("Something went wrong deep within the crossfire server. "
		1657	. "I'll try to bring you back to the map you were before. "
		1658	. "Please report this to the dungeon master",
		1659	cf::NDI_UNIQUE \| cf::NDI_RED);
		1660
		1661	warn "ERROR in enter_exit: $@";
		1662	$self->leave_link;
		1663	}
		1664	})->prio (1);
		1665	}
		1666
1078	=head3 cf::client	1667	=head3 cf::client
1079		1668
1080	=over 4	1669	=over 4
1081		1670
1082	=item $client->send_drawinfo ($text, $flags)	1671	=item $client->send_drawinfo ($text, $flags)
…		…
1125	on_reply => sub {	1714	on_reply => sub {
1126	my ($ns, $msg) = @_;	1715	my ($ns, $msg) = @_;
1127		1716
1128	# this weird shuffling is so that direct followup queries	1717	# this weird shuffling is so that direct followup queries
1129	# get handled first	1718	# get handled first
1130	my $queue = delete $ns->{query_queue};	1719	my $queue = delete $ns->{query_queue}
		1720	or return; # be conservative, not sure how that can happen, but we saw a crash here
1131		1721
1132	(shift @$queue)->[1]->($msg);	1722	(shift @$queue)->[1]->($msg);
1133		1723
1134	push @{ $ns->{query_queue} }, @$queue;	1724	push @{ $ns->{query_queue} }, @$queue;
1135		1725
…		…
1152	=cut	1742	=cut
1153		1743
1154	sub cf::client::coro {	1744	sub cf::client::coro {
1155	my ($self, $cb) = @_;	1745	my ($self, $cb) = @_;
1156		1746
1157	my $coro; $coro = async {	1747	my $coro = &cf::async ($cb);
1158	eval {
1159	$cb->();
1160	};
1161	warn $@ if $@;
1162	};
1163		1748
1164	$coro->on_destroy (sub {	1749	$coro->on_destroy (sub {
1165	delete $self->{_coro}{$coro+0};	1750	delete $self->{_coro}{$coro+0};
1166	});	1751	});
1167		1752
…		…
1339		1924
1340	{	1925	{
1341	my $path = cf::localdir . "/database.pst";	1926	my $path = cf::localdir . "/database.pst";
1342		1927
1343	sub db_load() {	1928	sub db_load() {
1344	warn "loading database $path\n";#d# remove later
1345	$DB = stat $path ? Storable::retrieve $path : { };	1929	$DB = stat $path ? Storable::retrieve $path : { };
1346	}	1930	}
1347		1931
1348	my $pid;	1932	my $pid;
1349		1933
1350	sub db_save() {	1934	sub db_save() {
1351	warn "saving database $path\n";#d# remove later
1352	waitpid $pid, 0 if $pid;	1935	waitpid $pid, 0 if $pid;
1353	if (0 == ($pid = fork)) {	1936	if (0 == ($pid = fork)) {
1354	$DB->{_meta}{version} = 1;	1937	$DB->{_meta}{version} = 1;
1355	Storable::nstore $DB, "$path~";	1938	Storable::nstore $DB, "$path~";
1356	rename "$path~", $path;	1939	rename "$path~", $path;
…		…
1404	open my $fh, "<:utf8", cf::confdir . "/config"	1987	open my $fh, "<:utf8", cf::confdir . "/config"
1405	or return;	1988	or return;
1406		1989
1407	local $/;	1990	local $/;
1408	*CFG = YAML::Syck::Load <$fh>;	1991	*CFG = YAML::Syck::Load <$fh>;
		1992
		1993	$EMERGENCY_POSITION = $CFG{emergency_position} \|\| ["/world/world_105_115", 5, 37];
		1994
		1995	if (exists $CFG{mlockall}) {
		1996	eval {
		1997	$CFG{mlockall} ? &mlockall : &munlockall
		1998	and die "WARNING: m(un)lockall failed: $!\n";
		1999	};
		2000	warn $@ if $@;
		2001	}
1409	}	2002	}
1410		2003
1411	sub main {	2004	sub main {
1412	# we must not ever block the main coroutine	2005	# we must not ever block the main coroutine
1413	local $Coro::idle = sub {	2006	local $Coro::idle = sub {
1414	Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#	2007	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1415	(Coro::unblock_sub {	2008	(Coro::unblock_sub {
1416	Event::one_event;	2009	Event::one_event;
1417	})->();	2010	})->();
1418	};	2011	};
1419		2012
…		…
1424	}	2017	}
1425		2018
1426	#############################################################################	2019	#############################################################################
1427	# initialisation	2020	# initialisation
1428		2021
1429	sub perl_reload() {	2022	sub reload() {
1430	# can/must only be called in main	2023	# can/must only be called in main
1431	if ($Coro::current != $Coro::main) {	2024	if ($Coro::current != $Coro::main) {
1432	warn "can only reload from main coroutine\n";	2025	warn "can only reload from main coroutine\n";
1433	return;	2026	return;
1434	}	2027	}
…		…
1527	$LINK_MAP->height (41);	2120	$LINK_MAP->height (41);
1528	$LINK_MAP->alloc;	2121	$LINK_MAP->alloc;
1529	$LINK_MAP->path ("{link}");	2122	$LINK_MAP->path ("{link}");
1530	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";	2123	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
1531	$LINK_MAP->in_memory (MAP_IN_MEMORY);	2124	$LINK_MAP->in_memory (MAP_IN_MEMORY);
		2125
		2126	# dirty hack because... archetypes are not yet loaded
		2127	Event->timer (
		2128	after => 2,
		2129	cb => sub {
		2130	$_[0]->w->cancel;
		2131
		2132	# provide some exits "home"
		2133	my $exit = cf::object::new "exit";
		2134
		2135	$exit->slaying ($EMERGENCY_POSITION->[0]);
		2136	$exit->stats->hp ($EMERGENCY_POSITION->[1]);
		2137	$exit->stats->sp ($EMERGENCY_POSITION->[2]);
		2138
		2139	$LINK_MAP->insert ($exit->clone, 19, 19);
		2140	$LINK_MAP->insert ($exit->clone, 19, 20);
		2141	$LINK_MAP->insert ($exit->clone, 19, 21);
		2142	$LINK_MAP->insert ($exit->clone, 20, 19);
		2143	$LINK_MAP->insert ($exit->clone, 20, 21);
		2144	$LINK_MAP->insert ($exit->clone, 21, 19);
		2145	$LINK_MAP->insert ($exit->clone, 21, 20);
		2146	$LINK_MAP->insert ($exit->clone, 21, 21);
		2147
		2148	$exit->destroy;
		2149	});
		2150
		2151	$LINK_MAP->{deny_save} = 1;
		2152	$LINK_MAP->{deny_reset} = 1;
		2153
		2154	$cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1532	}	2155	}
1533		2156
1534	register "<global>", __PACKAGE__;	2157	register "<global>", __PACKAGE__;
1535		2158
1536	register_command "perl-reload" => sub {	2159	register_command "reload" => sub {
1537	my ($who, $arg) = @_;	2160	my ($who, $arg) = @_;
1538		2161
1539	if ($who->flag (FLAG_WIZ)) {	2162	if ($who->flag (FLAG_WIZ)) {
1540	$who->message ("start of reload.");	2163	$who->message ("start of reload.");
1541	perl_reload;	2164	reload;
1542	$who->message ("end of reload.");	2165	$who->message ("end of reload.");
1543	}	2166	}
1544	};	2167	};
1545		2168
1546	unshift @INC, $LIBDIR;	2169	unshift @INC, $LIBDIR;
…		…
1586	or warn "ERROR: unable to write runtime file: $!";	2209	or warn "ERROR: unable to write runtime file: $!";
1587	})->();	2210	})->();
1588	},	2211	},
1589	);	2212	);
1590		2213
		2214	END { cf::emergency_save }
		2215
1591	1	2216	1
1592		2217

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.109 by root, Sun Dec 31 22:23:12 2006 UTC vs. Revision 1.131 by root, Thu Jan 4 00:53:54 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.109 by root, Sun Dec 31 22:23:12 2006 UTC vs.
Revision 1.131 by root, Thu Jan 4 00:53:54 2007 UTC