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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.108 by root, Sun Dec 31 21:02:05 2006 UTC vs.
Revision 1.122 by root, Tue Jan 2 17:32:24 2007 UTC

…		…
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
		77	our $EMERGENCY_POSITION = $cf::CFG{emergency_position} \|\| ["/world/world_105_115", 5, 37];
76		78
77	#############################################################################	79	#############################################################################
78		80
79	=head2 GLOBAL VARIABLES	81	=head2 GLOBAL VARIABLES
80		82
…		…
179	sub to_json($) {	181	sub to_json($) {
180	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	182	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
181	JSON::Syck::Dump $_[0]	183	JSON::Syck::Dump $_[0]
182	}	184	}
183		185
		186	=item my $guard = cf::guard { BLOCK }
		187
		188	Run the given callback when the guard object gets destroyed (useful for
		189	coroutine cancellations).
		190
		191	You can call C<< ->cancel >> on the guard object to stop the block from
		192	being executed.
		193
		194	=cut
		195
		196	sub guard(&) {
		197	bless \(my $cb = $_[0]), cf::guard::;
		198	}
		199
		200	sub cf::guard::cancel {
		201	${$_[0]} = sub { };
		202	}
		203
		204	sub cf::guard::DESTROY {
		205	${$_[0]}->();
		206	}
		207
		208	=item cf::lock_wait $string
		209
		210	Wait until the given lock is available. See cf::lock_acquire.
		211
		212	=item my $lock = cf::lock_acquire $string
		213
		214	Wait until the given lock is available and then acquires it and returns
		215	a guard object. If the guard object gets destroyed (goes out of scope,
		216	for example when the coroutine gets canceled), the lock is automatically
		217	returned.
		218
		219	Lock names should begin with a unique identifier (for example, find_map
		220	uses map_find and load_map uses map_load).
		221
		222	=cut
		223
		224	our %LOCK;
		225
		226	sub lock_wait($) {
		227	my ($key) = @_;
		228
		229	# wait for lock, if any
		230	while ($LOCK{$key}) {
		231	push @{ $LOCK{$key} }, $Coro::current;
		232	Coro::schedule;
		233	}
		234	}
		235
		236	sub lock_acquire($) {
		237	my ($key) = @_;
		238
		239	# wait, to be sure we are not locked
		240	lock_wait $key;
		241
		242	$LOCK{$key} = [];
		243
		244	cf::guard {
		245	# wake up all waiters, to be on the safe side
		246	$_->ready for @{ delete $LOCK{$key} };
		247	}
		248	}
		249
184	=item cf::sync_job { BLOCK }	250	=item cf::sync_job { BLOCK }
185		251
186	The design of crossfire+ requires that the main coro ($Coro::main) is	252	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	253	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.	254	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
…		…
195	=cut	261	=cut
196		262
197	sub sync_job(&) {	263	sub sync_job(&) {
198	my ($job) = @_;	264	my ($job) = @_;
199		265
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) {	266	if ($Coro::current == $Coro::main) {
		267	# this is the main coro, too bad, we have to block
		268	# till the operation succeeds, freezing the server :/
		269
		270	# TODO: use suspend/resume instead
		271	# (but this is cancel-safe)
		272	local $FREEZE = 1;
		273
		274	my $busy = 1;
		275	my @res;
		276
		277	(Coro::async {
		278	@res = eval { $job->() };
		279	warn $@ if $@;
		280	undef $busy;
213	$coro->prio (Coro::PRIO_MAX);	281	})->prio (Coro::PRIO_MAX);
		282
214	while ($busy) {	283	while ($busy) {
215	Coro::cede_notself;	284	Coro::cede_notself;
216	Event::one_event unless Coro::nready;	285	Event::one_event unless Coro::nready;
217	}	286	}
		287
		288	wantarray ? @res : $res[0]
218	} else {	289	} else {
219	$coro->join;	290	# we are in another coroutine, how wonderful, everything just works
		291
		292	$job->()
220	}	293	}
221
222	wantarray ? @res : $res[0]
223	}	294	}
224		295
225	=item $coro = cf::coro { BLOCK }	296	=item $coro = cf::coro { BLOCK }
226		297
227	Creates and returns a new coro. This coro is automcatially being canceled	298	Creates and returns a new coro. This coro is automcatially being canceled
…		…
251	my $runtime = cf::localdir . "/runtime";	322	my $runtime = cf::localdir . "/runtime";
252		323
253	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644	324	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644
254	or return;	325	or return;
255		326
256	my $value = $cf::RUNTIME;	327	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	328	(aio_write $fh, 0, (length $value), $value, 0) <= 0
258	and return;	329	and return;
259		330
260	aio_fsync $fh	331	aio_fsync $fh
261	and return;	332	and return;
…		…
278	package cf::path;	349	package cf::path;
279		350
280	sub new {	351	sub new {
281	my ($class, $path, $base) = @_;	352	my ($class, $path, $base) = @_;
282		353
		354	$path = $path->as_string if ref $path;
		355
283	my $self = bless { }, $class;	356	my $self = bless { }, $class;
284		357
		358	# {... are special paths that are not touched
		359	# ?xxx/... are special absolute paths
		360	# ?random/... random maps
		361	# /! non-realised random map exit
		362	# /... normal maps
		363	# ~/... per-player maps without a specific player (DO NOT USE)
		364	# ~user/... per-player map of a specific user
		365
		366	if ($path =~ /^{/) {
		367	# fine as it is
285	if ($path =~ s{^\?random/}{}) {	368	} elsif ($path =~ s{^\?random/}{}) {
		369	Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
286	$self->{random} = cf::from_json $path;	370	$self->{random} = cf::from_json $data;
287	} else {	371	} else {
288	if ($path =~ s{^~([^/]+)?}{}) {	372	if ($path =~ s{^~([^/]+)?}{}) {
289	$self->{user_rel} = 1;	373	$self->{user_rel} = 1;
290		374
291	if (defined $1) {	375	if (defined $1) {
…		…
324		408
325	# the displayed name, this is a one way mapping	409	# the displayed name, this is a one way mapping
326	sub visible_name {	410	sub visible_name {
327	my ($self) = @_;	411	my ($self) = @_;
328		412
329	$self->{random} ? "?random/$self->{random}{origin_map}+$self->{random}{origin_x}+$self->{random}{origin_y}/$self->{random}{dungeon_level}"	413	# if (my $rmp = $self->{random}) {
330	: $self->as_string	414	# # todo: be more intelligent about this
		415	# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
		416	# } else {
		417	$self->as_string
		418	# }
331	}	419	}
332		420
333	# escape the /'s in the path	421	# escape the /'s in the path
334	sub _escaped_path {	422	sub _escaped_path {
335	# ∕ is U+2215	423	# ∕ is U+2215
…		…
347	# the temporary/swap location	435	# the temporary/swap location
348	sub save_path {	436	sub save_path {
349	my ($self) = @_;	437	my ($self) = @_;
350		438
351	$self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path	439	$self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
352	: $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, Digest::MD5::md5_hex $self->{path}	440	: $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
353	: sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path	441	: sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
354	}	442	}
355		443
356	# the unique path, might be eq to save_path	444	# the unique path, might be eq to save_path
357	sub uniq_path {	445	sub uniq_path {
…		…
790	or return;	878	or return;
791		879
792	unless (aio_stat "$filename.pst") {	880	unless (aio_stat "$filename.pst") {
793	(aio_load "$filename.pst", $av) >= 0	881	(aio_load "$filename.pst", $av) >= 0
794	or return;	882	or return;
795	$av = eval { (Storable::thaw <$av>)->{objs} };	883	$av = eval { (Storable::thaw $av)->{objs} };
796	}	884	}
797		885
		886	warn sprintf "loading %s (%d)\n",
		887	$filename, length $data, scalar @{$av \|\| []};#d#
798	return ($data, $av);	888	return ($data, $av);
799	}	889	}
800		890
801	#############################################################################	891	#############################################################################
802	# command handling &c	892	# command handling &c
…		…
1024	$self->send ("ext " . to_json \%msg);	1114	$self->send ("ext " . to_json \%msg);
1025	}	1115	}
1026		1116
1027	=back	1117	=back
1028		1118
		1119
		1120	=head3 cf::map
		1121
		1122	=over 4
		1123
		1124	=cut
		1125
		1126	package cf::map;
		1127
		1128	use Fcntl;
		1129	use Coro::AIO;
		1130
		1131	our $MAX_RESET = 7200;
		1132	our $DEFAULT_RESET = 3600;
		1133
		1134	sub generate_random_map {
		1135	my ($path, $rmp) = @_;
		1136
		1137	# mit "rum" bekleckern, nicht
		1138	cf::map::_create_random_map
		1139	$path,
		1140	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
		1141	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
		1142	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
		1143	$rmp->{exit_on_final_map},
		1144	$rmp->{xsize}, $rmp->{ysize},
		1145	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
		1146	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
		1147	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
		1148	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
		1149	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
		1150	(cf::region::find $rmp->{region})
		1151	}
		1152
		1153	# and all this just because we cannot iterate over
		1154	# all maps in C++...
		1155	sub change_all_map_light {
		1156	my ($change) = @_;
		1157
		1158	$_->change_map_light ($change)
		1159	for grep $_->outdoor, values %cf::MAP;
		1160	}
		1161
		1162	sub try_load_header($) {
		1163	my ($path) = @_;
		1164
		1165	utf8::encode $path;
		1166	aio_open $path, O_RDONLY, 0
		1167	or return;
		1168
		1169	my $map = cf::map::new
		1170	or return;
		1171
		1172	$map->load_header ($path)
		1173	or return;
		1174
		1175	$map->{load_path} = $path;
		1176
		1177	$map
		1178	}
		1179
		1180	sub find_map {
		1181	my ($path, $origin) = @_;
		1182
		1183	#warn "find_map<$path,$origin>\n";#d#
		1184
		1185	$path = new cf::path $path, $origin && $origin->path;
		1186	my $key = $path->as_string;
		1187
		1188	cf::lock_wait "map_find:$key";
		1189
		1190	$cf::MAP{$key} \|\| do {
		1191	my $guard = cf::lock_acquire "map_find:$key";
		1192
		1193	# do it the slow way
		1194	my $map = try_load_header $path->save_path;
		1195
		1196	if ($map) {
		1197	# safety
		1198	$map->{instantiate_time} = $cf::RUNTIME
		1199	if $map->{instantiate_time} > $cf::RUNTIME;
		1200	} else {
		1201	if (my $rmp = $path->random_map_params) {
		1202	$map = generate_random_map $key, $rmp;
		1203	} else {
		1204	$map = try_load_header $path->load_path;
		1205	}
		1206
		1207	$map or return;
		1208
		1209	$map->{load_original} = 1;
		1210	$map->{instantiate_time} = $cf::RUNTIME;
		1211	$map->instantiate;
		1212
		1213	# per-player maps become, after loading, normal maps
		1214	$map->per_player (0) if $path->{user_rel};
		1215	}
		1216
		1217	$map->path ($key);
		1218	$map->{path} = $path;
		1219	$map->{last_save} = $cf::RUNTIME;
		1220	$map->last_access ($cf::RUNTIME);
		1221
		1222	if ($map->should_reset) {
		1223	$map->reset;
		1224	$map = find_map $path;
		1225	}
		1226
		1227	$cf::MAP{$key} = $map
		1228	}
		1229	}
		1230
		1231	sub load {
		1232	my ($self) = @_;
		1233
		1234	my $path = $self->{path};
		1235	my $guard = cf::lock_acquire "map_load:" . $path->as_string;
		1236
		1237	return if $self->in_memory != cf::MAP_SWAPPED;
		1238
		1239	$self->in_memory (cf::MAP_LOADING);
		1240
		1241	$self->alloc;
		1242	$self->load_objects ($self->{load_path}, 1)
		1243	or return;
		1244
		1245	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
		1246	if delete $self->{load_original};
		1247
		1248	if (my $uniq = $path->uniq_path) {
		1249	utf8::encode $uniq;
		1250	if (aio_open $uniq, O_RDONLY, 0) {
		1251	$self->clear_unique_items;
		1252	$self->load_objects ($uniq, 0);
		1253	}
		1254	}
		1255
		1256	# now do the right thing for maps
		1257	$self->link_multipart_objects;
		1258
		1259	if ($self->{path}->is_style_map) {
		1260	$self->{deny_save} = 1;
		1261	$self->{deny_reset} = 1;
		1262	} else {
		1263	$self->fix_auto_apply;
		1264	$self->decay_objects;
		1265	$self->update_buttons;
		1266	$self->set_darkness_map;
		1267	$self->difficulty ($self->estimate_difficulty)
		1268	unless $self->difficulty;
		1269	$self->activate;
		1270	}
		1271
		1272	$self->in_memory (cf::MAP_IN_MEMORY);
		1273	}
		1274
		1275	sub load_map_sync {
		1276	my ($path, $origin) = @_;
		1277
		1278	#warn "load_map_sync<$path, $origin>\n";#d#
		1279
		1280	cf::sync_job {
		1281	my $map = cf::map::find_map $path, $origin
		1282	or return;
		1283	$map->load;
		1284	$map
		1285	}
		1286	}
		1287
		1288	sub save {
		1289	my ($self) = @_;
		1290
		1291	$self->{last_save} = $cf::RUNTIME;
		1292
		1293	return unless $self->dirty;
		1294
		1295	my $save = $self->{path}->save_path; utf8::encode $save;
		1296	my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
		1297
		1298	$self->{load_path} = $save;
		1299
		1300	return if $self->{deny_save};
		1301
		1302	if ($uniq) {
		1303	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
		1304	$self->save_objects ($uniq, cf::IO_UNIQUES);
		1305	} else {
		1306	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);
		1307	}
		1308	}
		1309
		1310	sub swap_out {
		1311	my ($self) = @_;
		1312
		1313	return if $self->players;
		1314	return if $self->in_memory != cf::MAP_IN_MEMORY;
		1315	return if $self->{deny_save};
		1316
		1317	$self->save;
		1318	$self->clear;
		1319	$self->in_memory (cf::MAP_SWAPPED);
		1320	}
		1321
		1322	sub reset_at {
		1323	my ($self) = @_;
		1324
		1325	# TODO: safety, remove and allow resettable per-player maps
		1326	return 1e99 if $self->{path}{user_rel};
		1327	return 1e99 if $self->{deny_reset};
		1328
		1329	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		1330	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
		1331
		1332	$time + $to
		1333	}
		1334
		1335	sub should_reset {
		1336	my ($self) = @_;
		1337
		1338	$self->reset_at <= $cf::RUNTIME
		1339	}
		1340
		1341	sub unlink_save {
		1342	my ($self) = @_;
		1343
		1344	utf8::encode (my $save = $self->{path}->save_path);
		1345	aioreq_pri 3; IO::AIO::aio_unlink $save;
		1346	aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
		1347	}
		1348
		1349	sub rename {
		1350	my ($self, $new_path) = @_;
		1351
		1352	$self->unlink_save;
		1353
		1354	delete $cf::MAP{$self->path};
		1355	$self->{path} = new cf::path $new_path;
		1356	$self->path ($self->{path}->as_string);
		1357	$cf::MAP{$self->path} = $self;
		1358
		1359	$self->save;
		1360	}
		1361
		1362	sub reset {
		1363	my ($self) = @_;
		1364
		1365	return if $self->players;
		1366	return if $self->{path}{user_rel};#d#
		1367
		1368	warn "resetting map ", $self->path;#d#
		1369
		1370	delete $cf::MAP{$self->path};
		1371
		1372	$_->clear_links_to ($self) for values %cf::MAP;
		1373
		1374	$self->unlink_save;
		1375	$self->destroy;
		1376	}
		1377
		1378	my $nuke_counter = "aaaa";
		1379
		1380	sub nuke {
		1381	my ($self) = @_;
		1382
		1383	$self->{deny_save} = 1;
		1384	$self->reset_timeout (1);
		1385	$self->rename ("{nuke}/" . ($nuke_counter++));
		1386	$self->reset; # polite request, might not happen
		1387	}
		1388
		1389	sub customise_for {
		1390	my ($map, $ob) = @_;
		1391
		1392	if ($map->per_player) {
		1393	return cf::map::find_map "~" . $ob->name . "/" . $map->{path}{path};
		1394	}
		1395
		1396	$map
		1397	}
		1398
		1399	sub emergency_save {
		1400	local $cf::FREEZE = 1;
		1401
		1402	warn "enter emergency map save\n";
		1403
		1404	cf::sync_job {
		1405	warn "begin emergency map save\n";
		1406	$_->save for values %cf::MAP;
		1407	};
		1408
		1409	warn "end emergency map save\n";
		1410	}
		1411
		1412	package cf;
		1413
		1414	=back
		1415
		1416
1029	=head3 cf::object::player	1417	=head3 cf::object::player
1030		1418
1031	=over 4	1419	=over 4
1032		1420
1033	=item $player_object->reply ($npc, $msg[, $flags])	1421	=item $player_object->reply ($npc, $msg[, $flags])
…		…
1066		1454
1067	$self->flag (cf::FLAG_WIZ) \|\|	1455	$self->flag (cf::FLAG_WIZ) \|\|
1068	(ref $cf::CFG{"may_$access"}	1456	(ref $cf::CFG{"may_$access"}
1069	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	1457	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1070	: $cf::CFG{"may_$access"})	1458	: $cf::CFG{"may_$access"})
		1459	}
		1460
		1461	=item $player_object->enter_link
		1462
		1463	Freezes the player and moves him/her to a special map (C<{link}>).
		1464
		1465	The player should be reaosnably safe there for short amounts of time. You
		1466	I<MUST> call C<leave_link> as soon as possible, though.
		1467
		1468	=item $player_object->leave_link ($map, $x, $y)
		1469
		1470	Moves the player out of the specila link map onto the given map. If the
		1471	map is not valid (or omitted), the player will be moved back to the
		1472	location he/she was before the call to C<enter_link>, or, if that fails,
		1473	to the emergency map position.
		1474
		1475	Might block.
		1476
		1477	=cut
		1478
		1479	sub cf::object::player::enter_link {
		1480	my ($self) = @_;
		1481
		1482	$self->deactivate_recursive;
		1483
		1484	return if $self->map == $LINK_MAP;
		1485
		1486	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]
		1487	if $self->map;
		1488
		1489	$self->enter_map ($LINK_MAP, 20, 20);
		1490	}
		1491
		1492	sub cf::object::player::leave_link {
		1493	my ($self, $map, $x, $y) = @_;
		1494
		1495	my $link_pos = delete $self->{_link_pos};
		1496
		1497	unless ($map) {
		1498	# restore original map position
		1499	($map, $x, $y) = @{ $link_pos \|\| [] };
		1500	$map = cf::map::find_map $map;
		1501
		1502	unless ($map) {
		1503	($map, $x, $y) = @$EMERGENCY_POSITION;
		1504	$map = cf::map::find_map $map
		1505	or die "FATAL: cannot load emergency map\n";
		1506	}
		1507	}
		1508
		1509	($x, $y) = (-1, -1)
		1510	unless (defined $x) && (defined $y);
		1511
		1512	# use -1 or undef as default coordinates, not 0, 0
		1513	($x, $y) = ($map->enter_x, $map->enter_y)
		1514	if $x <=0 && $y <= 0;
		1515
		1516	$map->load;
		1517
		1518	$self->activate_recursive;
		1519	$self->enter_map ($map, $x, $y);
		1520	}
		1521
		1522	cf::player->attach (
		1523	on_logout => sub {
		1524	my ($pl) = @_;
		1525
		1526	# abort map switching before logout
		1527	if ($pl->ob->{_link_pos}) {
		1528	cf::sync_job {
		1529	$pl->ob->leave_link
		1530	};
		1531	}
		1532	},
		1533	on_login => sub {
		1534	my ($pl) = @_;
		1535
		1536	# try to abort aborted map switching on player login :)
		1537	# should happen only on crashes
		1538	if ($pl->ob->{_link_pos}) {
		1539	$pl->ob->enter_link;
		1540	Coro::async {
		1541	# we need this sleep as the login has a concurrent enter_exit running
		1542	# and this sleep increases chances of the player not ending up in scorn
		1543	Coro::Timer::sleep 1;
		1544	$pl->ob->leave_link;
		1545	};
		1546	}
		1547	},
		1548	);
		1549
		1550	=item $player_object->goto_map ($path, $x, $y)
		1551
		1552	=cut
		1553
		1554	sub cf::object::player::goto_map {
		1555	my ($self, $path, $x, $y) = @_;
		1556
		1557	$self->enter_link;
		1558
		1559	(Coro::async {
		1560	$path = new cf::path $path;
		1561
		1562	my $map = cf::map::find_map $path->as_string;
		1563	$map = $map->customise_for ($self) if $map;
		1564
		1565	# warn "entering ", $map->path, " at ($x, $y)\n"
		1566	# if $map;
		1567
		1568	$map or $self->message ("The exit is closed", cf::NDI_UNIQUE \| cf::NDI_RED);
		1569
		1570	$self->leave_link ($map, $x, $y);
		1571	})->prio (1);
		1572	}
		1573
		1574	=item $player_object->enter_exit ($exit_object)
		1575
		1576	=cut
		1577
		1578	sub parse_random_map_params {
		1579	my ($spec) = @_;
		1580
		1581	my $rmp = { # defaults
		1582	xsize => 10,
		1583	ysize => 10,
		1584	};
		1585
		1586	for (split /\n/, $spec) {
		1587	my ($k, $v) = split /\s+/, $_, 2;
		1588
		1589	$rmp->{lc $k} = $v if (length $k) && (length $v);
		1590	}
		1591
		1592	$rmp
		1593	}
		1594
		1595	sub prepare_random_map {
		1596	my ($exit) = @_;
		1597
		1598	# all this does is basically replace the /! path by
		1599	# a new random map path (?random/...) with a seed
		1600	# that depends on the exit object
		1601
		1602	my $rmp = parse_random_map_params $exit->msg;
		1603
		1604	if ($exit->map) {
		1605	$rmp->{region} = $exit->map->region_name;
		1606	$rmp->{origin_map} = $exit->map->path;
		1607	$rmp->{origin_x} = $exit->x;
		1608	$rmp->{origin_y} = $exit->y;
		1609	}
		1610
		1611	$rmp->{random_seed} \|\|= $exit->random_seed;
		1612
		1613	my $data = cf::to_json $rmp;
		1614	my $md5 = Digest::MD5::md5_hex $data;
		1615
		1616	if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY \| O_CREAT, 0666) {
		1617	aio_write $fh, 0, (length $data), $data, 0;
		1618
		1619	$exit->slaying ("?random/$md5");
		1620	$exit->msg (undef);
		1621	}
		1622	}
		1623
		1624	sub cf::object::player::enter_exit {
		1625	my ($self, $exit) = @_;
		1626
		1627	return unless $self->type == cf::PLAYER;
		1628
		1629	$self->enter_link;
		1630
		1631	(Coro::async {
		1632	unless (eval {
		1633
		1634	prepare_random_map $exit
		1635	if $exit->slaying eq "/!";
		1636
		1637	my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
		1638	$self->goto_map ($path, $exit->stats->hp, $exit->stats->sp);
		1639
		1640	1;
		1641	}) {
		1642	$self->message ("Something went wrong deep within the crossfire server. "
		1643	. "I'll try to bring you back to the map you were before. "
		1644	. "Please report this to the dungeon master",
		1645	cf::NDI_UNIQUE \| cf::NDI_RED);
		1646
		1647	warn "ERROR in enter_exit: $@";
		1648	$self->leave_link;
		1649	}
		1650	})->prio (1);
1071	}	1651	}
1072		1652
1073	=head3 cf::client	1653	=head3 cf::client
1074		1654
1075	=over 4	1655	=over 4
…		…
1334		1914
1335	{	1915	{
1336	my $path = cf::localdir . "/database.pst";	1916	my $path = cf::localdir . "/database.pst";
1337		1917
1338	sub db_load() {	1918	sub db_load() {
1339	warn "loading database $path\n";#d# remove later
1340	$DB = stat $path ? Storable::retrieve $path : { };	1919	$DB = stat $path ? Storable::retrieve $path : { };
1341	}	1920	}
1342		1921
1343	my $pid;	1922	my $pid;
1344		1923
1345	sub db_save() {	1924	sub db_save() {
1346	warn "saving database $path\n";#d# remove later
1347	waitpid $pid, 0 if $pid;	1925	waitpid $pid, 0 if $pid;
1348	if (0 == ($pid = fork)) {	1926	if (0 == ($pid = fork)) {
1349	$DB->{_meta}{version} = 1;	1927	$DB->{_meta}{version} = 1;
1350	Storable::nstore $DB, "$path~";	1928	Storable::nstore $DB, "$path~";
1351	rename "$path~", $path;	1929	rename "$path~", $path;
…		…
1404	}	1982	}
1405		1983
1406	sub main {	1984	sub main {
1407	# we must not ever block the main coroutine	1985	# we must not ever block the main coroutine
1408	local $Coro::idle = sub {	1986	local $Coro::idle = sub {
1409	Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#	1987	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1410	(Coro::unblock_sub {	1988	(Coro::unblock_sub {
1411	Event::one_event;	1989	Event::one_event;
1412	})->();	1990	})->();
1413	};	1991	};
1414		1992
…		…
1419	}	1997	}
1420		1998
1421	#############################################################################	1999	#############################################################################
1422	# initialisation	2000	# initialisation
1423		2001
1424	sub perl_reload() {	2002	sub reload() {
1425	# can/must only be called in main	2003	# can/must only be called in main
1426	if ($Coro::current != $Coro::main) {	2004	if ($Coro::current != $Coro::main) {
1427	warn "can only reload from main coroutine\n";	2005	warn "can only reload from main coroutine\n";
1428	return;	2006	return;
1429	}	2007	}
…		…
1522	$LINK_MAP->height (41);	2100	$LINK_MAP->height (41);
1523	$LINK_MAP->alloc;	2101	$LINK_MAP->alloc;
1524	$LINK_MAP->path ("{link}");	2102	$LINK_MAP->path ("{link}");
1525	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";	2103	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
1526	$LINK_MAP->in_memory (MAP_IN_MEMORY);	2104	$LINK_MAP->in_memory (MAP_IN_MEMORY);
		2105
		2106	# dirty hack because... archetypes are not yet loaded
		2107	Event->timer (
		2108	after => 2,
		2109	cb => sub {
		2110	$_[0]->w->cancel;
		2111
		2112	# provide some exits "home"
		2113	my $exit = cf::object::new "exit";
		2114
		2115	$exit->slaying ($EMERGENCY_POSITION->[0]);
		2116	$exit->stats->hp ($EMERGENCY_POSITION->[1]);
		2117	$exit->stats->sp ($EMERGENCY_POSITION->[2]);
		2118
		2119	$LINK_MAP->insert ($exit->clone, 19, 19);
		2120	$LINK_MAP->insert ($exit->clone, 19, 20);
		2121	$LINK_MAP->insert ($exit->clone, 19, 21);
		2122	$LINK_MAP->insert ($exit->clone, 20, 19);
		2123	$LINK_MAP->insert ($exit->clone, 20, 21);
		2124	$LINK_MAP->insert ($exit->clone, 21, 19);
		2125	$LINK_MAP->insert ($exit->clone, 21, 20);
		2126	$LINK_MAP->insert ($exit->clone, 21, 21);
		2127
		2128	$exit->destroy;
		2129	});
		2130
		2131	$LINK_MAP->{deny_save} = 1;
		2132	$LINK_MAP->{deny_reset} = 1;
		2133
		2134	$cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1527	}	2135	}
1528		2136
1529	register "<global>", __PACKAGE__;	2137	register "<global>", __PACKAGE__;
1530		2138
1531	register_command "perl-reload" => sub {	2139	register_command "reload" => sub {
1532	my ($who, $arg) = @_;	2140	my ($who, $arg) = @_;
1533		2141
1534	if ($who->flag (FLAG_WIZ)) {	2142	if ($who->flag (FLAG_WIZ)) {
1535	$who->message ("start of reload.");	2143	$who->message ("start of reload.");
1536	perl_reload;	2144	reload;
1537	$who->message ("end of reload.");	2145	$who->message ("end of reload.");
1538	}	2146	}
1539	};	2147	};
1540		2148
1541	unshift @INC, $LIBDIR;	2149	unshift @INC, $LIBDIR;

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.108 by root, Sun Dec 31 21:02:05 2006 UTC vs. Revision 1.122 by root, Tue Jan 2 17:32:24 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.108 by root, Sun Dec 31 21:02:05 2006 UTC vs.
Revision 1.122 by root, Tue Jan 2 17:32:24 2007 UTC