[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.140 by root, Fri Jan 5 20:04:02 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;
…		…
26	use Event; $Event::Eval = 1; # no idea why this is required, but it is	26	use Event; $Event::Eval = 1; # no idea why this is required, but it is
27		27
28	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?	28	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
29	$YAML::Syck::ImplicitUnicode = 1;	29	$YAML::Syck::ImplicitUnicode = 1;
30		30
31	$Coro::main->prio (2); # run main coroutine ("the server") with very high priority	31	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
32		32
33	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	33	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34		34
35	our %COMMAND = ();	35	our %COMMAND = ();
36	our %COMMAND_TIME = ();	36	our %COMMAND_TIME = ();
…		…
49	our $UPTIME; $UPTIME \|\|= time;	49	our $UPTIME; $UPTIME \|\|= time;
50	our $RUNTIME;	50	our $RUNTIME;
51		51
52	our %MAP; # all maps	52	our %MAP; # all maps
53	our $LINK_MAP; # the special {link} map	53	our $LINK_MAP; # the special {link} map
54	our $FREEZE;
55	our $RANDOM_MAPS = cf::localdir . "/random";	54	our $RANDOM_MAPS = cf::localdir . "/random";
56	our %EXT_CORO;	55	our %EXT_CORO;
57		56
58	binmode STDOUT;	57	binmode STDOUT;
59	binmode STDERR;	58	binmode STDERR;
…		…
71	mkdir cf::localdir . "/" . cf::uniquedir;	70	mkdir cf::localdir . "/" . cf::uniquedir;
72	mkdir $RANDOM_MAPS;	71	mkdir $RANDOM_MAPS;
73		72
74	# a special map that is always available	73	# a special map that is always available
75	our $LINK_MAP;	74	our $LINK_MAP;
		75	our $EMERGENCY_POSITION;
76		76
77	#############################################################################	77	#############################################################################
78		78
79	=head2 GLOBAL VARIABLES	79	=head2 GLOBAL VARIABLES
80		80
…		…
179	sub to_json($) {	179	sub to_json($) {
180	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	180	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
181	JSON::Syck::Dump $_[0]	181	JSON::Syck::Dump $_[0]
182	}	182	}
183		183
		184	=item cf::lock_wait $string
		185
		186	Wait until the given lock is available. See cf::lock_acquire.
		187
		188	=item my $lock = cf::lock_acquire $string
		189
		190	Wait until the given lock is available and then acquires it and returns
		191	a Coro::guard object. If the guard object gets destroyed (goes out of scope,
		192	for example when the coroutine gets canceled), the lock is automatically
		193	returned.
		194
		195	Lock names should begin with a unique identifier (for example, cf::map::find
		196	uses map_find and cf::map::load uses map_load).
		197
		198	=cut
		199
		200	our %LOCK;
		201
		202	sub lock_wait($) {
		203	my ($key) = @_;
		204
		205	# wait for lock, if any
		206	while ($LOCK{$key}) {
		207	push @{ $LOCK{$key} }, $Coro::current;
		208	Coro::schedule;
		209	}
		210	}
		211
		212	sub lock_acquire($) {
		213	my ($key) = @_;
		214
		215	# wait, to be sure we are not locked
		216	lock_wait $key;
		217
		218	$LOCK{$key} = [];
		219
		220	Coro::guard {
		221	# wake up all waiters, to be on the safe side
		222	$_->ready for @{ delete $LOCK{$key} };
		223	}
		224	}
		225
		226	sub freeze_mainloop {
		227	return unless $TICK_WATCHER->is_active;
		228
		229	my $guard = Coro::guard { $TICK_WATCHER->start };
		230	$TICK_WATCHER->stop;
		231	$guard
		232	}
		233
		234	=item cf::async { BLOCK }
		235
		236	Currently the same as Coro::async_pool, meaning you cannot use
		237	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
		238	thing you are allowed to do is call C<prio> on it.
		239
		240	=cut
		241
		242	BEGIN { *async = \&Coro::async_pool }
		243
184	=item cf::sync_job { BLOCK }	244	=item cf::sync_job { BLOCK }
185		245
186	The design of crossfire+ requires that the main coro ($Coro::main) is	246	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	247	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.	248	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
…		…
195	=cut	255	=cut
196		256
197	sub sync_job(&) {	257	sub sync_job(&) {
198	my ($job) = @_;	258	my ($job) = @_;
199		259
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) {	260	if ($Coro::current == $Coro::main) {
		261	# this is the main coro, too bad, we have to block
		262	# till the operation succeeds, freezing the server :/
		263
		264	# TODO: use suspend/resume instead
		265	# (but this is cancel-safe)
		266	my $freeze_guard = freeze_mainloop;
		267
		268	my $busy = 1;
		269	my @res;
		270
		271	(async {
		272	@res = eval { $job->() };
		273	warn $@ if $@;
		274	undef $busy;
213	$coro->prio (Coro::PRIO_MAX);	275	})->prio (Coro::PRIO_MAX);
		276
214	while ($busy) {	277	while ($busy) {
215	Coro::cede_notself;	278	unless (Coro::cede) {
216	Event::one_event unless Coro::nready;	279	Coro::nready ? Event::one_event 0 : Event::one_event;
		280	Coro::cede_notself unless Coro::cede;
217	}	281	}
		282	}
		283
		284	wantarray ? @res : $res[0]
218	} else {	285	} else {
219	$coro->join;	286	# we are in another coroutine, how wonderful, everything just works
		287
		288	$job->()
220	}	289	}
221
222	wantarray ? @res : $res[0]
223	}	290	}
224		291
225	=item $coro = cf::coro { BLOCK }	292	=item $coro = cf::async_ext { BLOCK }
226		293
227	Creates and returns a new coro. This coro is automcatially being canceled	294	Like async, but this coro is automcatially being canceled when the
228	when the extension calling this is being unloaded.	295	extension calling this is being unloaded.
229		296
230	=cut	297	=cut
231		298
232	sub coro(&) {	299	sub async_ext(&) {
233	my $cb = shift;	300	my $cb = shift;
234		301
235	my $coro; $coro = async {	302	my $coro = &Coro::async ($cb);
236	eval {
237	$cb->();
238	};
239	warn $@ if $@;
240	};
241		303
242	$coro->on_destroy (sub {	304	$coro->on_destroy (sub {
243	delete $EXT_CORO{$coro+0};	305	delete $EXT_CORO{$coro+0};
244	});	306	});
245	$EXT_CORO{$coro+0} = $coro;	307	$EXT_CORO{$coro+0} = $coro;
…		…
251	my $runtime = cf::localdir . "/runtime";	313	my $runtime = cf::localdir . "/runtime";
252		314
253	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644	315	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644
254	or return;	316	or return;
255		317
256	my $value = $cf::RUNTIME;	318	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	319	(aio_write $fh, 0, (length $value), $value, 0) <= 0
258	and return;	320	and return;
259		321
260	aio_fsync $fh	322	aio_fsync $fh
261	and return;	323	and return;
…		…
278	package cf::path;	340	package cf::path;
279		341
280	sub new {	342	sub new {
281	my ($class, $path, $base) = @_;	343	my ($class, $path, $base) = @_;
282		344
		345	$path = $path->as_string if ref $path;
		346
283	my $self = bless { }, $class;	347	my $self = bless { }, $class;
284		348
		349	# {... are special paths that are not touched
		350	# ?xxx/... are special absolute paths
		351	# ?random/... random maps
		352	# /! non-realised random map exit
		353	# /... normal maps
		354	# ~/... per-player maps without a specific player (DO NOT USE)
		355	# ~user/... per-player map of a specific user
		356
		357	if ($path =~ /^{/) {
		358	# fine as it is
285	if ($path =~ s{^\?random/}{}) {	359	} elsif ($path =~ s{^\?random/}{}) {
286	Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;	360	Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
287	$self->{random} = cf::from_json $data;	361	$self->{random} = cf::from_json $data;
288	} else {	362	} else {
289	if ($path =~ s{^~([^/]+)?}{}) {	363	if ($path =~ s{^~([^/]+)?}{}) {
290	$self->{user_rel} = 1;	364	$self->{user_rel} = 1;
…		…
795	or return;	869	or return;
796		870
797	unless (aio_stat "$filename.pst") {	871	unless (aio_stat "$filename.pst") {
798	(aio_load "$filename.pst", $av) >= 0	872	(aio_load "$filename.pst", $av) >= 0
799	or return;	873	or return;
800	$av = eval { (Storable::thaw <$av>)->{objs} };	874	$av = eval { (Storable::thaw $av)->{objs} };
801	}	875	}
802		876
		877	warn sprintf "loading %s (%d)\n",
		878	$filename, length $data, scalar @{$av \|\| []};#d#
803	return ($data, $av);	879	return ($data, $av);
804	}	880	}
805		881
806	#############################################################################	882	#############################################################################
807	# command handling &c	883	# command handling &c
…		…
1029	$self->send ("ext " . to_json \%msg);	1105	$self->send ("ext " . to_json \%msg);
1030	}	1106	}
1031		1107
1032	=back	1108	=back
1033		1109
		1110
		1111	=head3 cf::map
		1112
		1113	=over 4
		1114
		1115	=cut
		1116
		1117	package cf::map;
		1118
		1119	use Fcntl;
		1120	use Coro::AIO;
		1121
		1122	our $MAX_RESET = 3600;
		1123	our $DEFAULT_RESET = 3000;
		1124
		1125	sub generate_random_map {
		1126	my ($path, $rmp) = @_;
		1127
		1128	# mit "rum" bekleckern, nicht
		1129	cf::map::_create_random_map
		1130	$path,
		1131	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
		1132	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
		1133	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
		1134	$rmp->{exit_on_final_map},
		1135	$rmp->{xsize}, $rmp->{ysize},
		1136	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
		1137	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
		1138	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
		1139	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
		1140	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
		1141	(cf::region::find $rmp->{region})
		1142	}
		1143
		1144	# and all this just because we cannot iterate over
		1145	# all maps in C++...
		1146	sub change_all_map_light {
		1147	my ($change) = @_;
		1148
		1149	$_->change_map_light ($change)
		1150	for grep $_->outdoor, values %cf::MAP;
		1151	}
		1152
		1153	sub try_load_header($) {
		1154	my ($path) = @_;
		1155
		1156	utf8::encode $path;
		1157	aio_open $path, O_RDONLY, 0
		1158	or return;
		1159
		1160	my $map = cf::map::new
		1161	or return;
		1162
		1163	# for better error messages only, will be overwritten
		1164	$map->path ($path);
		1165
		1166	$map->load_header ($path)
		1167	or return;
		1168
		1169	$map->{load_path} = $path;
		1170
		1171	$map
		1172	}
		1173
		1174	sub find;
		1175	sub find {
		1176	my ($path, $origin) = @_;
		1177
		1178	#warn "find<$path,$origin>\n";#d#
		1179
		1180	$path = new cf::path $path, $origin && $origin->path;
		1181	my $key = $path->as_string;
		1182
		1183	cf::lock_wait "map_find:$key";
		1184
		1185	$cf::MAP{$key} \|\| do {
		1186	my $guard = cf::lock_acquire "map_find:$key";
		1187
		1188	# do it the slow way
		1189	my $map = try_load_header $path->save_path;
		1190
		1191	Coro::cede;
		1192
		1193	if ($map) {
		1194	$map->last_access ((delete $map->{last_access})
		1195	\|\| $cf::RUNTIME); #d#
		1196	# safety
		1197	$map->{instantiate_time} = $cf::RUNTIME
		1198	if $map->{instantiate_time} > $cf::RUNTIME;
		1199	} else {
		1200	if (my $rmp = $path->random_map_params) {
		1201	$map = generate_random_map $key, $rmp;
		1202	} else {
		1203	$map = try_load_header $path->load_path;
		1204	}
		1205
		1206	$map or return;
		1207
		1208	$map->{load_original} = 1;
		1209	$map->{instantiate_time} = $cf::RUNTIME;
		1210	$map->last_access ($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
		1221	Coro::cede;
		1222
		1223	if ($map->should_reset) {
		1224	$map->reset;
		1225	undef $guard;
		1226	$map = find $path
		1227	or return;
		1228	}
		1229
		1230	$cf::MAP{$key} = $map
		1231	}
		1232	}
		1233
		1234	sub load {
		1235	my ($self) = @_;
		1236
		1237	my $path = $self->{path};
		1238	my $guard = cf::lock_acquire "map_load:" . $path->as_string;
		1239
		1240	return if $self->in_memory != cf::MAP_SWAPPED;
		1241
		1242	$self->in_memory (cf::MAP_LOADING);
		1243
		1244	$self->alloc;
		1245	$self->load_objects ($self->{load_path}, 1)
		1246	or return;
		1247
		1248	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
		1249	if delete $self->{load_original};
		1250
		1251	if (my $uniq = $path->uniq_path) {
		1252	utf8::encode $uniq;
		1253	if (aio_open $uniq, O_RDONLY, 0) {
		1254	$self->clear_unique_items;
		1255	$self->load_objects ($uniq, 0);
		1256	}
		1257	}
		1258
		1259	Coro::cede;
		1260
		1261	# now do the right thing for maps
		1262	$self->link_multipart_objects;
		1263
		1264	if ($self->{path}->is_style_map) {
		1265	$self->{deny_save} = 1;
		1266	$self->{deny_reset} = 1;
		1267	} else {
		1268	$self->fix_auto_apply;
		1269	$self->decay_objects;
		1270	$self->update_buttons;
		1271	$self->set_darkness_map;
		1272	$self->difficulty ($self->estimate_difficulty)
		1273	unless $self->difficulty;
		1274	$self->activate;
		1275	}
		1276
		1277	Coro::cede;
		1278
		1279	$self->in_memory (cf::MAP_IN_MEMORY);
		1280	}
		1281
		1282	sub find_sync {
		1283	my ($path, $origin) = @_;
		1284
		1285	cf::sync_job { cf::map::find $path, $origin }
		1286	}
		1287
		1288	sub do_load_sync {
		1289	my ($map) = @_;
		1290
		1291	cf::sync_job { $map->load };
		1292	}
		1293
		1294	sub save {
		1295	my ($self) = @_;
		1296
		1297	my $lock = cf::lock_acquire "map_data:" . $self->path;
		1298
		1299	$self->{last_save} = $cf::RUNTIME;
		1300
		1301	return unless $self->dirty;
		1302
		1303	my $save = $self->{path}->save_path; utf8::encode $save;
		1304	my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
		1305
		1306	$self->{load_path} = $save;
		1307
		1308	return if $self->{deny_save};
		1309
		1310	local $self->{last_access} = $self->last_access;#d#
		1311
		1312	if ($uniq) {
		1313	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
		1314	$self->save_objects ($uniq, cf::IO_UNIQUES);
		1315	} else {
		1316	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);
		1317	}
		1318	}
		1319
		1320	sub swap_out {
		1321	my ($self) = @_;
		1322
		1323	# save first because save cedes
		1324	$self->save;
		1325
		1326	my $lock = cf::lock_acquire "map_data:" . $self->path;
		1327
		1328	return if $self->players;
		1329	return if $self->in_memory != cf::MAP_IN_MEMORY;
		1330	return if $self->{deny_save};
		1331
		1332	$self->clear;
		1333	$self->in_memory (cf::MAP_SWAPPED);
		1334	}
		1335
		1336	sub reset_at {
		1337	my ($self) = @_;
		1338
		1339	# TODO: safety, remove and allow resettable per-player maps
		1340	return 1e99 if $self->{path}{user_rel};
		1341	return 1e99 if $self->{deny_reset};
		1342
		1343	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		1344	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
		1345
		1346	$time + $to
		1347	}
		1348
		1349	sub should_reset {
		1350	my ($self) = @_;
		1351
		1352	$self->reset_at <= $cf::RUNTIME
		1353	}
		1354
		1355	sub unlink_save {
		1356	my ($self) = @_;
		1357
		1358	utf8::encode (my $save = $self->{path}->save_path);
		1359	aioreq_pri 3; IO::AIO::aio_unlink $save;
		1360	aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
		1361	}
		1362
		1363	sub rename {
		1364	my ($self, $new_path) = @_;
		1365
		1366	$self->unlink_save;
		1367
		1368	delete $cf::MAP{$self->path};
		1369	$self->{path} = new cf::path $new_path;
		1370	$self->path ($self->{path}->as_string);
		1371	$cf::MAP{$self->path} = $self;
		1372
		1373	$self->save;
		1374	}
		1375
		1376	sub reset {
		1377	my ($self) = @_;
		1378
		1379	my $lock = cf::lock_acquire "map_data:" . $self->path;
		1380
		1381	return if $self->players;
		1382	return if $self->{path}{user_rel};#d#
		1383
		1384	warn "resetting map ", $self->path;#d#
		1385
		1386	delete $cf::MAP{$self->path};
		1387
		1388	$_->clear_links_to ($self) for values %cf::MAP;
		1389
		1390	$self->unlink_save;
		1391	$self->destroy;
		1392	}
		1393
		1394	my $nuke_counter = "aaaa";
		1395
		1396	sub nuke {
		1397	my ($self) = @_;
		1398
		1399	$self->{deny_save} = 1;
		1400	$self->reset_timeout (1);
		1401	$self->rename ("{nuke}/" . ($nuke_counter++));
		1402	$self->reset; # polite request, might not happen
		1403	}
		1404
		1405	sub customise_for {
		1406	my ($map, $ob) = @_;
		1407
		1408	if ($map->per_player) {
		1409	return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};
		1410	}
		1411
		1412	$map
		1413	}
		1414
		1415	sub emergency_save {
		1416	my $freeze_guard = cf::freeze_mainloop;
		1417
		1418	warn "enter emergency map save\n";
		1419
		1420	cf::sync_job {
		1421	warn "begin emergency map save\n";
		1422	$_->save for values %cf::MAP;
		1423	};
		1424
		1425	warn "end emergency map save\n";
		1426	}
		1427
		1428	package cf;
		1429
		1430	=back
		1431
		1432
1034	=head3 cf::object::player	1433	=head3 cf::object::player
1035		1434
1036	=over 4	1435	=over 4
1037		1436
1038	=item $player_object->reply ($npc, $msg[, $flags])	1437	=item $player_object->reply ($npc, $msg[, $flags])
…		…
1073	(ref $cf::CFG{"may_$access"}	1472	(ref $cf::CFG{"may_$access"}
1074	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	1473	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1075	: $cf::CFG{"may_$access"})	1474	: $cf::CFG{"may_$access"})
1076	}	1475	}
1077		1476
		1477	=item $player_object->enter_link
		1478
		1479	Freezes the player and moves him/her to a special map (C<{link}>).
		1480
		1481	The player should be reaosnably safe there for short amounts of time. You
		1482	I<MUST> call C<leave_link> as soon as possible, though.
		1483
		1484	=item $player_object->leave_link ($map, $x, $y)
		1485
		1486	Moves the player out of the specila link map onto the given map. If the
		1487	map is not valid (or omitted), the player will be moved back to the
		1488	location he/she was before the call to C<enter_link>, or, if that fails,
		1489	to the emergency map position.
		1490
		1491	Might block.
		1492
		1493	=cut
		1494
		1495	sub cf::object::player::enter_link {
		1496	my ($self) = @_;
		1497
		1498	$self->deactivate_recursive;
		1499
		1500	return if $self->map == $LINK_MAP;
		1501
		1502	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]
		1503	if $self->map;
		1504
		1505	$self->enter_map ($LINK_MAP, 20, 20);
		1506	}
		1507
		1508	sub cf::object::player::leave_link {
		1509	my ($self, $map, $x, $y) = @_;
		1510
		1511	my $link_pos = delete $self->{_link_pos};
		1512
		1513	unless ($map) {
		1514	# restore original map position
		1515	($map, $x, $y) = @{ $link_pos \|\| [] };
		1516	$map = cf::map::find $map;
		1517
		1518	unless ($map) {
		1519	($map, $x, $y) = @$EMERGENCY_POSITION;
		1520	$map = cf::map::find $map
		1521	or die "FATAL: cannot load emergency map\n";
		1522	}
		1523	}
		1524
		1525	($x, $y) = (-1, -1)
		1526	unless (defined $x) && (defined $y);
		1527
		1528	# use -1 or undef as default coordinates, not 0, 0
		1529	($x, $y) = ($map->enter_x, $map->enter_y)
		1530	if $x <=0 && $y <= 0;
		1531
		1532	$map->load;
		1533
		1534	$self->activate_recursive;
		1535	$self->enter_map ($map, $x, $y);
		1536	}
		1537
		1538	cf::player->attach (
		1539	on_logout => sub {
		1540	my ($pl) = @_;
		1541
		1542	# abort map switching before logout
		1543	if ($pl->ob->{_link_pos}) {
		1544	cf::sync_job {
		1545	$pl->ob->leave_link
		1546	};
		1547	}
		1548	},
		1549	on_login => sub {
		1550	my ($pl) = @_;
		1551
		1552	# try to abort aborted map switching on player login :)
		1553	# should happen only on crashes
		1554	if ($pl->ob->{_link_pos}) {
		1555
		1556	$pl->ob->enter_link;
		1557	(async {
		1558	# we need this sleep as the login has a concurrent enter_exit running
		1559	# and this sleep increases chances of the player not ending up in scorn
		1560	$pl->ob->reply (undef,
		1561	"There was an internal problem at your last logout, "
		1562	. "the server will try to bring you to your intended destination in a second.",
		1563	cf::NDI_RED);
		1564	Coro::Timer::sleep 1;
		1565	$pl->ob->leave_link;
		1566	})->prio (2);
		1567	}
		1568	},
		1569	);
		1570
		1571	=item $player_object->goto ($path, $x, $y)
		1572
		1573	=cut
		1574
		1575	sub cf::object::player::goto {
		1576	my ($self, $path, $x, $y) = @_;
		1577
		1578	$self->enter_link;
		1579
		1580	(async {
		1581	$path = new cf::path $path;
		1582
		1583	my $map = cf::map::find $path->as_string;
		1584	$map = $map->customise_for ($self) if $map;
		1585
		1586	# warn "entering ", $map->path, " at ($x, $y)\n"
		1587	# if $map;
		1588
		1589	$map or $self->message ("The exit is closed", cf::NDI_UNIQUE \| cf::NDI_RED);
		1590
		1591	$self->leave_link ($map, $x, $y);
		1592	})->prio (1);
		1593	}
		1594
		1595	=item $player_object->enter_exit ($exit_object)
		1596
		1597	=cut
		1598
		1599	sub parse_random_map_params {
		1600	my ($spec) = @_;
		1601
		1602	my $rmp = { # defaults
		1603	xsize => 10,
		1604	ysize => 10,
		1605	};
		1606
		1607	for (split /\n/, $spec) {
		1608	my ($k, $v) = split /\s+/, $_, 2;
		1609
		1610	$rmp->{lc $k} = $v if (length $k) && (length $v);
		1611	}
		1612
		1613	$rmp
		1614	}
		1615
		1616	sub prepare_random_map {
		1617	my ($exit) = @_;
		1618
		1619	# all this does is basically replace the /! path by
		1620	# a new random map path (?random/...) with a seed
		1621	# that depends on the exit object
		1622
		1623	my $rmp = parse_random_map_params $exit->msg;
		1624
		1625	if ($exit->map) {
		1626	$rmp->{region} = $exit->map->region_name;
		1627	$rmp->{origin_map} = $exit->map->path;
		1628	$rmp->{origin_x} = $exit->x;
		1629	$rmp->{origin_y} = $exit->y;
		1630	}
		1631
		1632	$rmp->{random_seed} \|\|= $exit->random_seed;
		1633
		1634	my $data = cf::to_json $rmp;
		1635	my $md5 = Digest::MD5::md5_hex $data;
		1636
		1637	if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY \| O_CREAT, 0666) {
		1638	aio_write $fh, 0, (length $data), $data, 0;
		1639
		1640	$exit->slaying ("?random/$md5");
		1641	$exit->msg (undef);
		1642	}
		1643	}
		1644
		1645	sub cf::object::player::enter_exit {
		1646	my ($self, $exit) = @_;
		1647
		1648	return unless $self->type == cf::PLAYER;
		1649
		1650	$self->enter_link;
		1651
		1652	(async {
		1653	$self->deactivate_recursive; # just to be sure
		1654	unless (eval {
		1655	prepare_random_map $exit
		1656	if $exit->slaying eq "/!";
		1657
		1658	my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
		1659	$self->goto ($path, $exit->stats->hp, $exit->stats->sp);
		1660
		1661	1;
		1662	}) {
		1663	$self->message ("Something went wrong deep within the crossfire server. "
		1664	. "I'll try to bring you back to the map you were before. "
		1665	. "Please report this to the dungeon master",
		1666	cf::NDI_UNIQUE \| cf::NDI_RED);
		1667
		1668	warn "ERROR in enter_exit: $@";
		1669	$self->leave_link;
		1670	}
		1671	})->prio (1);
		1672	}
		1673
1078	=head3 cf::client	1674	=head3 cf::client
1079		1675
1080	=over 4	1676	=over 4
1081		1677
1082	=item $client->send_drawinfo ($text, $flags)	1678	=item $client->send_drawinfo ($text, $flags)
…		…
1125	on_reply => sub {	1721	on_reply => sub {
1126	my ($ns, $msg) = @_;	1722	my ($ns, $msg) = @_;
1127		1723
1128	# this weird shuffling is so that direct followup queries	1724	# this weird shuffling is so that direct followup queries
1129	# get handled first	1725	# get handled first
1130	my $queue = delete $ns->{query_queue};	1726	my $queue = delete $ns->{query_queue}
		1727	or return; # be conservative, not sure how that can happen, but we saw a crash here
1131		1728
1132	(shift @$queue)->[1]->($msg);	1729	(shift @$queue)->[1]->($msg);
1133		1730
1134	push @{ $ns->{query_queue} }, @$queue;	1731	push @{ $ns->{query_queue} }, @$queue;
1135		1732
…		…
1141	}	1738	}
1142	}	1739	}
1143	},	1740	},
1144	);	1741	);
1145		1742
1146	=item $client->coro (\&cb)	1743	=item $client->async (\&cb)
1147		1744
1148	Create a new coroutine, running the specified callback. The coroutine will	1745	Create a new coroutine, running the specified callback. The coroutine will
1149	be automatically cancelled when the client gets destroyed (e.g. on logout,	1746	be automatically cancelled when the client gets destroyed (e.g. on logout,
1150	or loss of connection).	1747	or loss of connection).
1151		1748
1152	=cut	1749	=cut
1153		1750
1154	sub cf::client::coro {	1751	sub cf::client::async {
1155	my ($self, $cb) = @_;	1752	my ($self, $cb) = @_;
1156		1753
1157	my $coro; $coro = async {	1754	my $coro = &Coro::async ($cb);
1158	eval {
1159	$cb->();
1160	};
1161	warn $@ if $@;
1162	};
1163		1755
1164	$coro->on_destroy (sub {	1756	$coro->on_destroy (sub {
1165	delete $self->{_coro}{$coro+0};	1757	delete $self->{_coro}{$coro+0};
1166	});	1758	});
1167		1759
…		…
1339		1931
1340	{	1932	{
1341	my $path = cf::localdir . "/database.pst";	1933	my $path = cf::localdir . "/database.pst";
1342		1934
1343	sub db_load() {	1935	sub db_load() {
1344	warn "loading database $path\n";#d# remove later
1345	$DB = stat $path ? Storable::retrieve $path : { };	1936	$DB = stat $path ? Storable::retrieve $path : { };
1346	}	1937	}
1347		1938
1348	my $pid;	1939	my $pid;
1349		1940
1350	sub db_save() {	1941	sub db_save() {
1351	warn "saving database $path\n";#d# remove later
1352	waitpid $pid, 0 if $pid;	1942	waitpid $pid, 0 if $pid;
1353	if (0 == ($pid = fork)) {	1943	if (0 == ($pid = fork)) {
1354	$DB->{_meta}{version} = 1;	1944	$DB->{_meta}{version} = 1;
1355	Storable::nstore $DB, "$path~";	1945	Storable::nstore $DB, "$path~";
1356	rename "$path~", $path;	1946	rename "$path~", $path;
…		…
1404	open my $fh, "<:utf8", cf::confdir . "/config"	1994	open my $fh, "<:utf8", cf::confdir . "/config"
1405	or return;	1995	or return;
1406		1996
1407	local $/;	1997	local $/;
1408	*CFG = YAML::Syck::Load <$fh>;	1998	*CFG = YAML::Syck::Load <$fh>;
		1999
		2000	$EMERGENCY_POSITION = $CFG{emergency_position} \|\| ["/world/world_105_115", 5, 37];
		2001
		2002	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
		2003	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
		2004
		2005	if (exists $CFG{mlockall}) {
		2006	eval {
		2007	$CFG{mlockall} ? &mlockall : &munlockall
		2008	and die "WARNING: m(un)lockall failed: $!\n";
		2009	};
		2010	warn $@ if $@;
		2011	}
1409	}	2012	}
1410		2013
1411	sub main {	2014	sub main {
1412	# we must not ever block the main coroutine	2015	# we must not ever block the main coroutine
1413	local $Coro::idle = sub {	2016	local $Coro::idle = sub {
1414	Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#	2017	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1415	(Coro::unblock_sub {
1416	Event::one_event;	2018	async { Event::one_event };
1417	})->();
1418	};	2019	};
1419		2020
1420	cfg_load;	2021	cfg_load;
1421	db_load;	2022	db_load;
1422	load_extensions;	2023	load_extensions;
…		…
1424	}	2025	}
1425		2026
1426	#############################################################################	2027	#############################################################################
1427	# initialisation	2028	# initialisation
1428		2029
1429	sub perl_reload() {	2030	sub reload() {
1430	# can/must only be called in main	2031	# can/must only be called in main
1431	if ($Coro::current != $Coro::main) {	2032	if ($Coro::current != $Coro::main) {
1432	warn "can only reload from main coroutine\n";	2033	warn "can only reload from main coroutine\n";
1433	return;	2034	return;
1434	}	2035	}
1435		2036
1436	warn "reloading...";	2037	warn "reloading...";
1437		2038
1438	local $FREEZE = 1;	2039	my $guard = freeze_mainloop;
1439	cf::emergency_save;	2040	cf::emergency_save;
1440		2041
1441	eval {	2042	eval {
1442	# if anything goes wrong in here, we should simply crash as we already saved	2043	# if anything goes wrong in here, we should simply crash as we already saved
1443		2044
…		…
1527	$LINK_MAP->height (41);	2128	$LINK_MAP->height (41);
1528	$LINK_MAP->alloc;	2129	$LINK_MAP->alloc;
1529	$LINK_MAP->path ("{link}");	2130	$LINK_MAP->path ("{link}");
1530	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";	2131	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
1531	$LINK_MAP->in_memory (MAP_IN_MEMORY);	2132	$LINK_MAP->in_memory (MAP_IN_MEMORY);
		2133
		2134	# dirty hack because... archetypes are not yet loaded
		2135	Event->timer (
		2136	after => 2,
		2137	cb => sub {
		2138	$_[0]->w->cancel;
		2139
		2140	# provide some exits "home"
		2141	my $exit = cf::object::new "exit";
		2142
		2143	$exit->slaying ($EMERGENCY_POSITION->[0]);
		2144	$exit->stats->hp ($EMERGENCY_POSITION->[1]);
		2145	$exit->stats->sp ($EMERGENCY_POSITION->[2]);
		2146
		2147	$LINK_MAP->insert ($exit->clone, 19, 19);
		2148	$LINK_MAP->insert ($exit->clone, 19, 20);
		2149	$LINK_MAP->insert ($exit->clone, 19, 21);
		2150	$LINK_MAP->insert ($exit->clone, 20, 19);
		2151	$LINK_MAP->insert ($exit->clone, 20, 21);
		2152	$LINK_MAP->insert ($exit->clone, 21, 19);
		2153	$LINK_MAP->insert ($exit->clone, 21, 20);
		2154	$LINK_MAP->insert ($exit->clone, 21, 21);
		2155
		2156	$exit->destroy;
		2157	});
		2158
		2159	$LINK_MAP->{deny_save} = 1;
		2160	$LINK_MAP->{deny_reset} = 1;
		2161
		2162	$cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1532	}	2163	}
1533		2164
1534	register "<global>", __PACKAGE__;	2165	register "<global>", __PACKAGE__;
1535		2166
1536	register_command "perl-reload" => sub {	2167	register_command "reload" => sub {
1537	my ($who, $arg) = @_;	2168	my ($who, $arg) = @_;
1538		2169
1539	if ($who->flag (FLAG_WIZ)) {	2170	if ($who->flag (FLAG_WIZ)) {
1540	$who->message ("start of reload.");	2171	$who->message ("start of reload.");
1541	perl_reload;	2172	reload;
1542	$who->message ("end of reload.");	2173	$who->message ("end of reload.");
1543	}	2174	}
1544	};	2175	};
1545		2176
1546	unshift @INC, $LIBDIR;	2177	unshift @INC, $LIBDIR;
…		…
1549	reentrant => 0,	2180	reentrant => 0,
1550	prio => 0,	2181	prio => 0,
1551	at => $NEXT_TICK \|\| $TICK,	2182	at => $NEXT_TICK \|\| $TICK,
1552	data => WF_AUTOCANCEL,	2183	data => WF_AUTOCANCEL,
1553	cb => sub {	2184	cb => sub {
1554	unless ($FREEZE) {
1555	cf::server_tick; # one server iteration	2185	cf::server_tick; # one server iteration
1556	$RUNTIME += $TICK;	2186	$RUNTIME += $TICK;
1557	}
1558
1559	$NEXT_TICK += $TICK;	2187	$NEXT_TICK += $TICK;
1560		2188
1561	# if we are delayed by four ticks or more, skip them all	2189	# if we are delayed by four ticks or more, skip them all
1562	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	2190	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1563		2191
…		…
1586	or warn "ERROR: unable to write runtime file: $!";	2214	or warn "ERROR: unable to write runtime file: $!";
1587	})->();	2215	})->();
1588	},	2216	},
1589	);	2217	);
1590		2218
		2219	END { cf::emergency_save }
		2220
1591	1	2221	1
1592		2222

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.140 by root, Fri Jan 5 20:04:02 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.140 by root, Fri Jan 5 20:04:02 2007 UTC