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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.107 by root, Sun Dec 31 18:10:40 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;
19		19
		20	use Digest::MD5;
20	use Fcntl;	21	use Fcntl;
21	use IO::AIO 2.31 ();	22	use IO::AIO 2.31 ();
22	use YAML::Syck ();	23	use YAML::Syck ();
23	use Time::HiRes;	24	use Time::HiRes;
24		25
25	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
26		27
27	# 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?
28	$YAML::Syck::ImplicitUnicode = 1;	29	$YAML::Syck::ImplicitUnicode = 1;
29		30
30	$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
31		32
32	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	33	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
33		34
34	our %COMMAND = ();	35	our %COMMAND = ();
35	our %COMMAND_TIME = ();	36	our %COMMAND_TIME = ();
…		…
48	our $UPTIME; $UPTIME \|\|= time;	49	our $UPTIME; $UPTIME \|\|= time;
49	our $RUNTIME;	50	our $RUNTIME;
50		51
51	our %MAP; # all maps	52	our %MAP; # all maps
52	our $LINK_MAP; # the special {link} map	53	our $LINK_MAP; # the special {link} map
53	our $FREEZE;	54	our $RANDOM_MAPS = cf::localdir . "/random";
		55	our %EXT_CORO;
54		56
55	binmode STDOUT;	57	binmode STDOUT;
56	binmode STDERR;	58	binmode STDERR;
57		59
58	# read virtual server time, if available	60	# read virtual server time, if available
…		…
64		66
65	mkdir cf::localdir;	67	mkdir cf::localdir;
66	mkdir cf::localdir . "/" . cf::playerdir;	68	mkdir cf::localdir . "/" . cf::playerdir;
67	mkdir cf::localdir . "/" . cf::tmpdir;	69	mkdir cf::localdir . "/" . cf::tmpdir;
68	mkdir cf::localdir . "/" . cf::uniquedir;	70	mkdir cf::localdir . "/" . cf::uniquedir;
		71	mkdir $RANDOM_MAPS;
69		72
70	our %EXT_CORO;	73	# a special map that is always available
		74	our $LINK_MAP;
		75	our $EMERGENCY_POSITION;
71		76
72	#############################################################################	77	#############################################################################
73		78
74	=head2 GLOBAL VARIABLES	79	=head2 GLOBAL VARIABLES
75		80
…		…
174	sub to_json($) {	179	sub to_json($) {
175	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	180	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
176	JSON::Syck::Dump $_[0]	181	JSON::Syck::Dump $_[0]
177	}	182	}
178		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
179	=item cf::sync_job { BLOCK }	244	=item cf::sync_job { BLOCK }
180		245
181	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
182	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
183	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.
…		…
190	=cut	255	=cut
191		256
192	sub sync_job(&) {	257	sub sync_job(&) {
193	my ($job) = @_;	258	my ($job) = @_;
194		259
195	my $busy = 1;
196	my @res;
197
198	# TODO: use suspend/resume instead
199	local $FREEZE = 1;
200
201	my $coro = Coro::async {
202	@res = eval { $job->() };
203	warn $@ if $@;
204	undef $busy;
205	};
206
207	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;
208	$coro->prio (Coro::PRIO_MAX);	275	})->prio (Coro::PRIO_MAX);
		276
209	while ($busy) {	277	while ($busy) {
210	Coro::cede_notself;	278	unless (Coro::cede) {
211	Event::one_event unless Coro::nready;	279	Coro::nready ? Event::one_event 0 : Event::one_event;
		280	Coro::cede_notself unless Coro::cede;
212	}	281	}
		282	}
		283
		284	wantarray ? @res : $res[0]
213	} else {	285	} else {
214	$coro->join;	286	# we are in another coroutine, how wonderful, everything just works
		287
		288	$job->()
215	}	289	}
216
217	wantarray ? @res : $res[0]
218	}	290	}
219		291
220	=item $coro = cf::coro { BLOCK }	292	=item $coro = cf::async_ext { BLOCK }
221		293
222	Creates and returns a new coro. This coro is automcatially being canceled	294	Like async, but this coro is automcatially being canceled when the
223	when the extension calling this is being unloaded.	295	extension calling this is being unloaded.
224		296
225	=cut	297	=cut
226		298
227	sub coro(&) {	299	sub async_ext(&) {
228	my $cb = shift;	300	my $cb = shift;
229		301
230	my $coro; $coro = async {	302	my $coro = &Coro::async ($cb);
231	eval {
232	$cb->();
233	};
234	warn $@ if $@;
235	};
236		303
237	$coro->on_destroy (sub {	304	$coro->on_destroy (sub {
238	delete $EXT_CORO{$coro+0};	305	delete $EXT_CORO{$coro+0};
239	});	306	});
240	$EXT_CORO{$coro+0} = $coro;	307	$EXT_CORO{$coro+0} = $coro;
241		308
242	$coro	309	$coro
243	}	310	}
244		311
		312	sub write_runtime {
		313	my $runtime = cf::localdir . "/runtime";
		314
		315	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644
		316	or return;
		317
		318	my $value = $cf::RUNTIME + 1 + 10; # 10 is the runtime save interval, for a monotonic clock
		319	(aio_write $fh, 0, (length $value), $value, 0) <= 0
		320	and return;
		321
		322	aio_fsync $fh
		323	and return;
		324
		325	close $fh
		326	or return;
		327
		328	aio_rename "$runtime~", $runtime
		329	and return;
		330
		331	1
		332	}
		333
245	=back	334	=back
246		335
247	=cut	336	=cut
		337
		338	#############################################################################
		339
		340	package cf::path;
		341
		342	sub new {
		343	my ($class, $path, $base) = @_;
		344
		345	$path = $path->as_string if ref $path;
		346
		347	my $self = bless { }, $class;
		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
		359	} elsif ($path =~ s{^\?random/}{}) {
		360	Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
		361	$self->{random} = cf::from_json $data;
		362	} else {
		363	if ($path =~ s{^~([^/]+)?}{}) {
		364	$self->{user_rel} = 1;
		365
		366	if (defined $1) {
		367	$self->{user} = $1;
		368	} elsif ($base =~ m{^~([^/]+)/}) {
		369	$self->{user} = $1;
		370	} else {
		371	warn "cannot resolve user-relative path without user <$path,$base>\n";
		372	}
		373	} elsif ($path =~ /^\//) {
		374	# already absolute
		375	} else {
		376	$base =~ s{[^/]+/?$}{};
		377	return $class->new ("$base/$path");
		378	}
		379
		380	for ($path) {
		381	redo if s{/\.?/}{/};
		382	redo if s{/[^/]+/\.\./}{/};
		383	}
		384	}
		385
		386	$self->{path} = $path;
		387
		388	$self
		389	}
		390
		391	# the name / primary key / in-game path
		392	sub as_string {
		393	my ($self) = @_;
		394
		395	$self->{user_rel} ? "~$self->{user}$self->{path}"
		396	: $self->{random} ? "?random/$self->{path}"
		397	: $self->{path}
		398	}
		399
		400	# the displayed name, this is a one way mapping
		401	sub visible_name {
		402	my ($self) = @_;
		403
		404	# if (my $rmp = $self->{random}) {
		405	# # todo: be more intelligent about this
		406	# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
		407	# } else {
		408	$self->as_string
		409	# }
		410	}
		411
		412	# escape the /'s in the path
		413	sub _escaped_path {
		414	# ∕ is U+2215
		415	(my $path = $_[0]{path}) =~ s/\//∕/g;
		416	$path
		417	}
		418
		419	# the original (read-only) location
		420	sub load_path {
		421	my ($self) = @_;
		422
		423	sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
		424	}
		425
		426	# the temporary/swap location
		427	sub save_path {
		428	my ($self) = @_;
		429
		430	$self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
		431	: $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
		432	: sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
		433	}
		434
		435	# the unique path, might be eq to save_path
		436	sub uniq_path {
		437	my ($self) = @_;
		438
		439	$self->{user_rel} \|\| $self->{random}
		440	? undef
		441	: sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
		442	}
		443
		444	# return random map parameters, or undef
		445	sub random_map_params {
		446	my ($self) = @_;
		447
		448	$self->{random}
		449	}
		450
		451	# this is somewhat ugly, but style maps do need special treatment
		452	sub is_style_map {
		453	$_[0]{path} =~ m{^/styles/}
		454	}
		455
		456	package cf;
248		457
249	#############################################################################	458	#############################################################################
250		459
251	=head2 ATTACHABLE OBJECTS	460	=head2 ATTACHABLE OBJECTS
252		461
…		…
660	or return;	869	or return;
661		870
662	unless (aio_stat "$filename.pst") {	871	unless (aio_stat "$filename.pst") {
663	(aio_load "$filename.pst", $av) >= 0	872	(aio_load "$filename.pst", $av) >= 0
664	or return;	873	or return;
665	$av = eval { (Storable::thaw <$av>)->{objs} };	874	$av = eval { (Storable::thaw $av)->{objs} };
666	}	875	}
667		876
		877	warn sprintf "loading %s (%d)\n",
		878	$filename, length $data, scalar @{$av \|\| []};#d#
668	return ($data, $av);	879	return ($data, $av);
669	}	880	}
670		881
671	#############################################################################	882	#############################################################################
672	# command handling &c	883	# command handling &c
…		…
894	$self->send ("ext " . to_json \%msg);	1105	$self->send ("ext " . to_json \%msg);
895	}	1106	}
896		1107
897	=back	1108	=back
898		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
899	=head3 cf::object::player	1433	=head3 cf::object::player
900		1434
901	=over 4	1435	=over 4
902		1436
903	=item $player_object->reply ($npc, $msg[, $flags])	1437	=item $player_object->reply ($npc, $msg[, $flags])
…		…
938	(ref $cf::CFG{"may_$access"}	1472	(ref $cf::CFG{"may_$access"}
939	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	1473	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
940	: $cf::CFG{"may_$access"})	1474	: $cf::CFG{"may_$access"})
941	}	1475	}
942		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
943	=head3 cf::client	1674	=head3 cf::client
944		1675
945	=over 4	1676	=over 4
946		1677
947	=item $client->send_drawinfo ($text, $flags)	1678	=item $client->send_drawinfo ($text, $flags)
…		…
990	on_reply => sub {	1721	on_reply => sub {
991	my ($ns, $msg) = @_;	1722	my ($ns, $msg) = @_;
992		1723
993	# this weird shuffling is so that direct followup queries	1724	# this weird shuffling is so that direct followup queries
994	# get handled first	1725	# get handled first
995	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
996		1728
997	(shift @$queue)->[1]->($msg);	1729	(shift @$queue)->[1]->($msg);
998		1730
999	push @{ $ns->{query_queue} }, @$queue;	1731	push @{ $ns->{query_queue} }, @$queue;
1000		1732
…		…
1006	}	1738	}
1007	}	1739	}
1008	},	1740	},
1009	);	1741	);
1010		1742
1011	=item $client->coro (\&cb)	1743	=item $client->async (\&cb)
1012		1744
1013	Create a new coroutine, running the specified callback. The coroutine will	1745	Create a new coroutine, running the specified callback. The coroutine will
1014	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,
1015	or loss of connection).	1747	or loss of connection).
1016		1748
1017	=cut	1749	=cut
1018		1750
1019	sub cf::client::coro {	1751	sub cf::client::async {
1020	my ($self, $cb) = @_;	1752	my ($self, $cb) = @_;
1021		1753
1022	my $coro; $coro = async {	1754	my $coro = &Coro::async ($cb);
1023	eval {
1024	$cb->();
1025	};
1026	warn $@ if $@;
1027	};
1028		1755
1029	$coro->on_destroy (sub {	1756	$coro->on_destroy (sub {
1030	delete $self->{_coro}{$coro+0};	1757	delete $self->{_coro}{$coro+0};
1031	});	1758	});
1032		1759
…		…
1204		1931
1205	{	1932	{
1206	my $path = cf::localdir . "/database.pst";	1933	my $path = cf::localdir . "/database.pst";
1207		1934
1208	sub db_load() {	1935	sub db_load() {
1209	warn "loading database $path\n";#d# remove later
1210	$DB = stat $path ? Storable::retrieve $path : { };	1936	$DB = stat $path ? Storable::retrieve $path : { };
1211	}	1937	}
1212		1938
1213	my $pid;	1939	my $pid;
1214		1940
1215	sub db_save() {	1941	sub db_save() {
1216	warn "saving database $path\n";#d# remove later
1217	waitpid $pid, 0 if $pid;	1942	waitpid $pid, 0 if $pid;
1218	if (0 == ($pid = fork)) {	1943	if (0 == ($pid = fork)) {
1219	$DB->{_meta}{version} = 1;	1944	$DB->{_meta}{version} = 1;
1220	Storable::nstore $DB, "$path~";	1945	Storable::nstore $DB, "$path~";
1221	rename "$path~", $path;	1946	rename "$path~", $path;
…		…
1269	open my $fh, "<:utf8", cf::confdir . "/config"	1994	open my $fh, "<:utf8", cf::confdir . "/config"
1270	or return;	1995	or return;
1271		1996
1272	local $/;	1997	local $/;
1273	*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	}
1274	}	2012	}
1275		2013
1276	sub main {	2014	sub main {
		2015	# we must not ever block the main coroutine
		2016	local $Coro::idle = sub {
		2017	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
		2018	async { Event::one_event };
		2019	};
		2020
1277	cfg_load;	2021	cfg_load;
1278	db_load;	2022	db_load;
1279	load_extensions;	2023	load_extensions;
1280	Event::loop;	2024	Event::loop;
1281	}	2025	}
1282		2026
1283	#############################################################################	2027	#############################################################################
1284	# initialisation	2028	# initialisation
1285		2029
1286	sub perl_reload() {	2030	sub reload() {
1287	# can/must only be called in main	2031	# can/must only be called in main
1288	if ($Coro::current != $Coro::main) {	2032	if ($Coro::current != $Coro::main) {
1289	warn "can only reload from main coroutine\n";	2033	warn "can only reload from main coroutine\n";
1290	return;	2034	return;
1291	}	2035	}
1292		2036
1293	warn "reloading...";	2037	warn "reloading...";
1294		2038
1295	local $FREEZE = 1;	2039	my $guard = freeze_mainloop;
1296	cf::emergency_save;	2040	cf::emergency_save;
1297		2041
1298	eval {	2042	eval {
1299	# 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
1300		2044
…		…
1373	}	2117	}
1374		2118
1375	warn "reloaded successfully";	2119	warn "reloaded successfully";
1376	};	2120	};
1377		2121
		2122	#############################################################################
		2123
		2124	unless ($LINK_MAP) {
		2125	$LINK_MAP = cf::map::new;
		2126
		2127	$LINK_MAP->width (41);
		2128	$LINK_MAP->height (41);
		2129	$LINK_MAP->alloc;
		2130	$LINK_MAP->path ("{link}");
		2131	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
		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;
		2163	}
		2164
1378	register "<global>", __PACKAGE__;	2165	register "<global>", __PACKAGE__;
1379		2166
1380	register_command "perl-reload" => sub {	2167	register_command "reload" => sub {
1381	my ($who, $arg) = @_;	2168	my ($who, $arg) = @_;
1382		2169
1383	if ($who->flag (FLAG_WIZ)) {	2170	if ($who->flag (FLAG_WIZ)) {
1384	$who->message ("start of reload.");	2171	$who->message ("start of reload.");
1385	perl_reload;	2172	reload;
1386	$who->message ("end of reload.");	2173	$who->message ("end of reload.");
1387	}	2174	}
1388	};	2175	};
1389		2176
1390	unshift @INC, $LIBDIR;	2177	unshift @INC, $LIBDIR;
…		…
1393	reentrant => 0,	2180	reentrant => 0,
1394	prio => 0,	2181	prio => 0,
1395	at => $NEXT_TICK \|\| $TICK,	2182	at => $NEXT_TICK \|\| $TICK,
1396	data => WF_AUTOCANCEL,	2183	data => WF_AUTOCANCEL,
1397	cb => sub {	2184	cb => sub {
1398	unless ($FREEZE) {
1399	cf::server_tick; # one server iteration	2185	cf::server_tick; # one server iteration
1400	$RUNTIME += $TICK;	2186	$RUNTIME += $TICK;
1401	}
1402
1403	$NEXT_TICK += $TICK;	2187	$NEXT_TICK += $TICK;
1404		2188
1405	# 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
1406	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	2190	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1407		2191
…		…
1410	},	2194	},
1411	);	2195	);
1412		2196
1413	IO::AIO::max_poll_time $TICK * 0.2;	2197	IO::AIO::max_poll_time $TICK * 0.2;
1414		2198
		2199	Event->io (
1415	Event->io (fd => IO::AIO::poll_fileno,	2200	fd => IO::AIO::poll_fileno,
1416	poll => 'r',	2201	poll => 'r',
1417	prio => 5,	2202	prio => 5,
1418	data => WF_AUTOCANCEL,	2203	data => WF_AUTOCANCEL,
1419	cb => \&IO::AIO::poll_cb);	2204	cb => \&IO::AIO::poll_cb,
		2205	);
1420		2206
1421	# we must not ever block the main coroutine	2207	Event->timer (
1422	$Coro::idle = sub {	2208	data => WF_AUTOCANCEL,
1423	#Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#	2209	after => 0,
1424	warn "FATAL: Coro::idle was called, major BUG\n";	2210	interval => 10,
		2211	cb => sub {
1425	(Coro::unblock_sub {	2212	(Coro::unblock_sub {
1426	Event::one_event;	2213	write_runtime
		2214	or warn "ERROR: unable to write runtime file: $!";
1427	})->();	2215	})->();
1428	};	2216	},
		2217	);
		2218
		2219	END { cf::emergency_save }
1429		2220
1430	1	2221	1
1431		2222

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.107 by root, Sun Dec 31 18:10:40 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.107 by root, Sun Dec 31 18:10:40 2006 UTC vs.
Revision 1.140 by root, Fri Jan 5 20:04:02 2007 UTC