[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.151 by root, Mon Jan 8 20:59:15 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 Digest::MD5;
21	use Fcntl;	21	use Fcntl;
22	use IO::AIO 2.31 ();	22	use IO::AIO 2.32 ();
23	use YAML::Syck ();	23	use YAML::Syck ();
24	use Time::HiRes;	24	use Time::HiRes;
25		25
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 = ();
…		…
47	our %CFG;	47	our %CFG;
48		48
49	our $UPTIME; $UPTIME \|\|= time;	49	our $UPTIME; $UPTIME \|\|= time;
50	our $RUNTIME;	50	our $RUNTIME;
51		51
		52	our %PLAYER; # all users
52	our %MAP; # all maps	53	our %MAP; # all maps
53	our $LINK_MAP; # the special {link} map	54	our $LINK_MAP; # the special {link} map
54	our $FREEZE;
55	our $RANDOM_MAPS = cf::localdir . "/random";	55	our $RANDOM_MAPS = cf::localdir . "/random";
56	our %EXT_CORO;	56	our %EXT_CORO; # coroutines bound to extensions
57		57
58	binmode STDOUT;	58	binmode STDOUT;
59	binmode STDERR;	59	binmode STDERR;
60		60
61	# read virtual server time, if available	61	# read virtual server time, if available
…		…
71	mkdir cf::localdir . "/" . cf::uniquedir;	71	mkdir cf::localdir . "/" . cf::uniquedir;
72	mkdir $RANDOM_MAPS;	72	mkdir $RANDOM_MAPS;
73		73
74	# a special map that is always available	74	# a special map that is always available
75	our $LINK_MAP;	75	our $LINK_MAP;
		76	our $EMERGENCY_POSITION;
76		77
77	#############################################################################	78	#############################################################################
78		79
79	=head2 GLOBAL VARIABLES	80	=head2 GLOBAL VARIABLES
80		81
…		…
117	utf8::encode $msg;	118	utf8::encode $msg;
118		119
119	$msg .= "\n"	120	$msg .= "\n"
120	unless $msg =~ /\n$/;	121	unless $msg =~ /\n$/;
121		122
122	LOG llevError, "cfperl: $msg";	123	LOG llevError, $msg;
123	};	124	};
124	}	125	}
125		126
126	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	127	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
127	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	128	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
…		…
179	sub to_json($) {	180	sub to_json($) {
180	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs	181	$JSON::Syck::ImplicitUnicode = 0; # work around JSON::Syck bugs
181	JSON::Syck::Dump $_[0]	182	JSON::Syck::Dump $_[0]
182	}	183	}
183		184
		185	=item cf::lock_wait $string
		186
		187	Wait until the given lock is available. See cf::lock_acquire.
		188
		189	=item my $lock = cf::lock_acquire $string
		190
		191	Wait until the given lock is available and then acquires it and returns
		192	a Coro::guard object. If the guard object gets destroyed (goes out of scope,
		193	for example when the coroutine gets canceled), the lock is automatically
		194	returned.
		195
		196	Lock names should begin with a unique identifier (for example, cf::map::find
		197	uses map_find and cf::map::load uses map_load).
		198
		199	=cut
		200
		201	our %LOCK;
		202
		203	sub lock_wait($) {
		204	my ($key) = @_;
		205
		206	# wait for lock, if any
		207	while ($LOCK{$key}) {
		208	push @{ $LOCK{$key} }, $Coro::current;
		209	Coro::schedule;
		210	}
		211	}
		212
		213	sub lock_acquire($) {
		214	my ($key) = @_;
		215
		216	# wait, to be sure we are not locked
		217	lock_wait $key;
		218
		219	$LOCK{$key} = [];
		220
		221	Coro::guard {
		222	# wake up all waiters, to be on the safe side
		223	$_->ready for @{ delete $LOCK{$key} };
		224	}
		225	}
		226
		227	sub freeze_mainloop {
		228	return unless $TICK_WATCHER->is_active;
		229
		230	my $guard = Coro::guard { $TICK_WATCHER->start };
		231	$TICK_WATCHER->stop;
		232	$guard
		233	}
		234
		235	=item cf::async { BLOCK }
		236
		237	Currently the same as Coro::async_pool, meaning you cannot use
		238	C<on_destroy>, C<join> or other gimmicks on these coroutines. The only
		239	thing you are allowed to do is call C<prio> on it.
		240
		241	=cut
		242
		243	BEGIN { *async = \&Coro::async_pool }
		244
184	=item cf::sync_job { BLOCK }	245	=item cf::sync_job { BLOCK }
185		246
186	The design of crossfire+ requires that the main coro ($Coro::main) is	247	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	248	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.	249	reentrant. Thus "blocking" it by e.g. waiting for I/O is not acceptable.
…		…
195	=cut	256	=cut
196		257
197	sub sync_job(&) {	258	sub sync_job(&) {
198	my ($job) = @_;	259	my ($job) = @_;
199		260
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) {	261	if ($Coro::current == $Coro::main) {
		262	# this is the main coro, too bad, we have to block
		263	# till the operation succeeds, freezing the server :/
		264
		265	# TODO: use suspend/resume instead
		266	# (but this is cancel-safe)
		267	my $freeze_guard = freeze_mainloop;
		268
		269	my $busy = 1;
		270	my @res;
		271
		272	(async {
		273	@res = eval { $job->() };
		274	warn $@ if $@;
		275	undef $busy;
213	$coro->prio (Coro::PRIO_MAX);	276	})->prio (Coro::PRIO_MAX);
		277
214	while ($busy) {	278	while ($busy) {
215	Coro::cede_notself;	279	Coro::cede or Event::one_event;
216	Event::one_event unless Coro::nready;
217	}	280	}
		281
		282	wantarray ? @res : $res[0]
218	} else {	283	} else {
219	$coro->join;	284	# we are in another coroutine, how wonderful, everything just works
		285
		286	$job->()
220	}	287	}
221
222	wantarray ? @res : $res[0]
223	}	288	}
224		289
225	=item $coro = cf::coro { BLOCK }	290	=item $coro = cf::async_ext { BLOCK }
226		291
227	Creates and returns a new coro. This coro is automcatially being canceled	292	Like async, but this coro is automcatially being canceled when the
228	when the extension calling this is being unloaded.	293	extension calling this is being unloaded.
229		294
230	=cut	295	=cut
231		296
232	sub coro(&) {	297	sub async_ext(&) {
233	my $cb = shift;	298	my $cb = shift;
234		299
235	my $coro; $coro = async {	300	my $coro = &Coro::async ($cb);
236	eval {
237	$cb->();
238	};
239	warn $@ if $@;
240	};
241		301
242	$coro->on_destroy (sub {	302	$coro->on_destroy (sub {
243	delete $EXT_CORO{$coro+0};	303	delete $EXT_CORO{$coro+0};
244	});	304	});
245	$EXT_CORO{$coro+0} = $coro;	305	$EXT_CORO{$coro+0} = $coro;
…		…
251	my $runtime = cf::localdir . "/runtime";	311	my $runtime = cf::localdir . "/runtime";
252		312
253	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644	313	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644
254	or return;	314	or return;
255		315
256	my $value = $cf::RUNTIME;	316	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	317	(aio_write $fh, 0, (length $value), $value, 0) <= 0
258	and return;	318	and return;
259		319
260	aio_fsync $fh	320	aio_fsync $fh
261	and return;	321	and return;
…		…
278	package cf::path;	338	package cf::path;
279		339
280	sub new {	340	sub new {
281	my ($class, $path, $base) = @_;	341	my ($class, $path, $base) = @_;
282		342
		343	$path = $path->as_string if ref $path;
		344
283	my $self = bless { }, $class;	345	my $self = bless { }, $class;
284		346
		347	# {... are special paths that are not touched
		348	# ?xxx/... are special absolute paths
		349	# ?random/... random maps
		350	# /! non-realised random map exit
		351	# /... normal maps
		352	# ~/... per-player maps without a specific player (DO NOT USE)
		353	# ~user/... per-player map of a specific user
		354
		355	if ($path =~ /^{/) {
		356	# fine as it is
285	if ($path =~ s{^\?random/}{}) {	357	} elsif ($path =~ s{^\?random/}{}) {
		358	Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
286	$self->{random} = cf::from_json $path;	359	$self->{random} = cf::from_json $data;
287	} else {	360	} else {
288	if ($path =~ s{^~([^/]+)?}{}) {	361	if ($path =~ s{^~([^/]+)?}{}) {
289	$self->{user_rel} = 1;	362	$self->{user_rel} = 1;
290		363
291	if (defined $1) {	364	if (defined $1) {
…		…
324		397
325	# the displayed name, this is a one way mapping	398	# the displayed name, this is a one way mapping
326	sub visible_name {	399	sub visible_name {
327	my ($self) = @_;	400	my ($self) = @_;
328		401
329	$self->{random} ? "?random/$self->{random}{origin_map}+$self->{random}{origin_x}+$self->{random}{origin_y}/$self->{random}{dungeon_level}"	402	# if (my $rmp = $self->{random}) {
330	: $self->as_string	403	# # todo: be more intelligent about this
		404	# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
		405	# } else {
		406	$self->as_string
		407	# }
331	}	408	}
332		409
333	# escape the /'s in the path	410	# escape the /'s in the path
334	sub _escaped_path {	411	sub _escaped_path {
335	# ∕ is U+2215	412	# ∕ is U+2215
…		…
347	# the temporary/swap location	424	# the temporary/swap location
348	sub save_path {	425	sub save_path {
349	my ($self) = @_;	426	my ($self) = @_;
350		427
351	$self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path	428	$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}	429	: $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
353	: sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path	430	: sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
354	}	431	}
355		432
356	# the unique path, might be eq to save_path	433	# the unique path, might be eq to save_path
357	sub uniq_path {	434	sub uniq_path {
…		…
790	or return;	867	or return;
791		868
792	unless (aio_stat "$filename.pst") {	869	unless (aio_stat "$filename.pst") {
793	(aio_load "$filename.pst", $av) >= 0	870	(aio_load "$filename.pst", $av) >= 0
794	or return;	871	or return;
795	$av = eval { (Storable::thaw <$av>)->{objs} };	872	$av = eval { (Storable::thaw $av)->{objs} };
796	}	873	}
797		874
		875	warn sprintf "loading %s (%d)\n",
		876	$filename, length $data, scalar @{$av \|\| []};#d#
798	return ($data, $av);	877	return ($data, $av);
799	}	878	}
800		879
801	#############################################################################	880	#############################################################################
802	# command handling &c	881	# command handling &c
…		…
993		1072
994	=head2 CORE EXTENSIONS	1073	=head2 CORE EXTENSIONS
995		1074
996	Functions and methods that extend core crossfire objects.	1075	Functions and methods that extend core crossfire objects.
997		1076
		1077	=cut
		1078
		1079	package cf::player;
		1080
998	=head3 cf::player	1081	=head3 cf::player
999		1082
1000	=over 4	1083	=over 4
1001		1084
1002	=item cf::player::exists $login	1085	=item cf::player::find $login
1003		1086
1004	Returns true when the given account exists.	1087	Returns the given player object, loading it if necessary (might block).
1005		1088
1006	=cut	1089	=cut
1007		1090
1008	sub cf::player::exists($) {	1091	sub playerdir($) {
1009	cf::player::find $_[0]	1092	cf::localdir
1010	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;	1093	. "/"
		1094	. cf::playerdir
		1095	. "/"
		1096	. (ref $_[0] ? $_[0]->ob->name : $_[0])
		1097	}
		1098
		1099	sub path($) {
		1100	my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
		1101
		1102	(playerdir $login) . "/$login.pl"
		1103	}
		1104
		1105	sub find_active($) {
		1106	$cf::PLAYER{$_[0]}
		1107	and $cf::PLAYER{$_[0]}->active
		1108	and $cf::PLAYER{$_[0]}
		1109	}
		1110
		1111	sub exists($) {
		1112	my ($login) = @_;
		1113
		1114	$cf::PLAYER{$login}
		1115	or cf::sync_job { !aio_stat $login }
		1116	}
		1117
		1118	sub find($) {
		1119	return $cf::PLAYER{$_[0]} \|\| do {
		1120	my $login = $_[0];
		1121
		1122	my $guard = cf::lock_acquire "user_find:$login";
		1123
		1124	$cf::PLAYER{$_[0]} \|\| do {
		1125	my $pl = load_pl path $login
		1126	or return;
		1127	$cf::PLAYER{$login} = $pl
		1128	}
		1129	}
		1130	}
		1131
		1132	sub save($) {
		1133	my ($pl) = @_;
		1134
		1135	return if $pl->{deny_save};
		1136
		1137	my $path = path $pl;
		1138	my $guard = cf::lock_acquire "user_save:$path";
		1139
		1140	return if $pl->{deny_save};
		1141
		1142	Coro::AIO::aio_mkdir playerdir $pl, 0770;
		1143	$pl->{last_save} = $cf::RUNTIME;
		1144
		1145	$pl->save_pl ($path);
		1146	Coro::cede;
		1147	}
		1148
		1149	sub new($) {
		1150	my ($login) = @_;
		1151
		1152	my $self = create;
		1153
		1154	$self->ob->name ($login);
		1155	$self->{deny_save} = 1;
		1156
		1157	$cf::PLAYER{$login} = $self;
		1158
		1159	$self
		1160	}
		1161
		1162	sub quit_character {
		1163	my ($pl) = @_;
		1164
		1165	$pl->{deny_save} = 1;
		1166	$pl->password ("*"); # this should lock out the player until we nuked the dir
		1167
		1168	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
		1169	$pl->deactivate;
		1170	$pl->invoke (cf::EVENT_PLAYER_QUIT);
		1171	$pl->ns->destroy if $pl->ns;
		1172
		1173	my $path = playerdir $pl;
		1174	my $temp = "$path~$cf::RUNTIME~deleting~";
		1175	Coro::AIO::aio_rename $path, $temp;
		1176	delete $cf::PLAYER{$pl->ob->name};
		1177	$pl->destroy;
		1178	IO::AIO::aio_rmtree $temp;
1011	}	1179	}
1012		1180
1013	=item $player->ext_reply ($msgid, $msgtype, %msg)	1181	=item $player->ext_reply ($msgid, $msgtype, %msg)
1014		1182
1015	Sends an ext reply to the player.	1183	Sends an ext reply to the player.
1016		1184
1017	=cut	1185	=cut
1018		1186
1019	sub cf::player::ext_reply($$$%) {	1187	sub ext_reply($$$%) {
1020	my ($self, $id, %msg) = @_;	1188	my ($self, $id, %msg) = @_;
1021		1189
1022	$msg{msgid} = $id;	1190	$msg{msgid} = $id;
1023		1191
1024	$self->send ("ext " . to_json \%msg);	1192	$self->send ("ext " . cf::to_json \%msg);
1025	}	1193	}
		1194
		1195	package cf;
1026		1196
1027	=back	1197	=back
		1198
		1199
		1200	=head3 cf::map
		1201
		1202	=over 4
		1203
		1204	=cut
		1205
		1206	package cf::map;
		1207
		1208	use Fcntl;
		1209	use Coro::AIO;
		1210
		1211	our $MAX_RESET = 3600;
		1212	our $DEFAULT_RESET = 3000;
		1213
		1214	sub generate_random_map {
		1215	my ($path, $rmp) = @_;
		1216
		1217	# mit "rum" bekleckern, nicht
		1218	cf::map::_create_random_map
		1219	$path,
		1220	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
		1221	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
		1222	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
		1223	$rmp->{exit_on_final_map},
		1224	$rmp->{xsize}, $rmp->{ysize},
		1225	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
		1226	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
		1227	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
		1228	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
		1229	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
		1230	(cf::region::find $rmp->{region})
		1231	}
		1232
		1233	# and all this just because we cannot iterate over
		1234	# all maps in C++...
		1235	sub change_all_map_light {
		1236	my ($change) = @_;
		1237
		1238	$_->change_map_light ($change)
		1239	for grep $_->outdoor, values %cf::MAP;
		1240	}
		1241
		1242	sub try_load_header($) {
		1243	my ($path) = @_;
		1244
		1245	utf8::encode $path;
		1246	aio_open $path, O_RDONLY, 0
		1247	or return;
		1248
		1249	my $map = cf::map::new
		1250	or return;
		1251
		1252	# for better error messages only, will be overwritten
		1253	$map->path ($path);
		1254
		1255	$map->load_header ($path)
		1256	or return;
		1257
		1258	$map->{load_path} = $path;
		1259
		1260	$map
		1261	}
		1262
		1263	sub find;
		1264	sub find {
		1265	my ($path, $origin) = @_;
		1266
		1267	#warn "find<$path,$origin>\n";#d#
		1268
		1269	$path = new cf::path $path, $origin && $origin->path;
		1270	my $key = $path->as_string;
		1271
		1272	cf::lock_wait "map_find:$key";
		1273
		1274	$cf::MAP{$key} \|\| do {
		1275	my $guard = cf::lock_acquire "map_find:$key";
		1276
		1277	# do it the slow way
		1278	my $map = try_load_header $path->save_path;
		1279
		1280	Coro::cede;
		1281
		1282	if ($map) {
		1283	$map->last_access ((delete $map->{last_access})
		1284	\|\| $cf::RUNTIME); #d#
		1285	# safety
		1286	$map->{instantiate_time} = $cf::RUNTIME
		1287	if $map->{instantiate_time} > $cf::RUNTIME;
		1288	} else {
		1289	if (my $rmp = $path->random_map_params) {
		1290	$map = generate_random_map $key, $rmp;
		1291	} else {
		1292	$map = try_load_header $path->load_path;
		1293	}
		1294
		1295	$map or return;
		1296
		1297	$map->{load_original} = 1;
		1298	$map->{instantiate_time} = $cf::RUNTIME;
		1299	$map->last_access ($cf::RUNTIME);
		1300	$map->instantiate;
		1301
		1302	# per-player maps become, after loading, normal maps
		1303	$map->per_player (0) if $path->{user_rel};
		1304	}
		1305
		1306	$map->path ($key);
		1307	$map->{path} = $path;
		1308	$map->{last_save} = $cf::RUNTIME;
		1309
		1310	Coro::cede;
		1311
		1312	if ($map->should_reset) {
		1313	$map->reset;
		1314	undef $guard;
		1315	$map = find $path
		1316	or return;
		1317	}
		1318
		1319	$cf::MAP{$key} = $map
		1320	}
		1321	}
		1322
		1323	sub load {
		1324	my ($self) = @_;
		1325
		1326	my $path = $self->{path};
		1327	my $guard = cf::lock_acquire "map_load:" . $path->as_string;
		1328
		1329	return if $self->in_memory != cf::MAP_SWAPPED;
		1330
		1331	$self->in_memory (cf::MAP_LOADING);
		1332
		1333	$self->alloc;
		1334	$self->load_objects ($self->{load_path}, 1)
		1335	or return;
		1336
		1337	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
		1338	if delete $self->{load_original};
		1339
		1340	if (my $uniq = $path->uniq_path) {
		1341	utf8::encode $uniq;
		1342	if (aio_open $uniq, O_RDONLY, 0) {
		1343	$self->clear_unique_items;
		1344	$self->load_objects ($uniq, 0);
		1345	}
		1346	}
		1347
		1348	Coro::cede;
		1349
		1350	# now do the right thing for maps
		1351	$self->link_multipart_objects;
		1352
		1353	if ($self->{path}->is_style_map) {
		1354	$self->{deny_save} = 1;
		1355	$self->{deny_reset} = 1;
		1356	} else {
		1357	$self->fix_auto_apply;
		1358	$self->decay_objects;
		1359	$self->update_buttons;
		1360	$self->set_darkness_map;
		1361	$self->difficulty ($self->estimate_difficulty)
		1362	unless $self->difficulty;
		1363	$self->activate;
		1364	}
		1365
		1366	Coro::cede;
		1367
		1368	$self->in_memory (cf::MAP_IN_MEMORY);
		1369	}
		1370
		1371	sub find_sync {
		1372	my ($path, $origin) = @_;
		1373
		1374	cf::sync_job { cf::map::find $path, $origin }
		1375	}
		1376
		1377	sub do_load_sync {
		1378	my ($map) = @_;
		1379
		1380	cf::sync_job { $map->load };
		1381	}
		1382
		1383	sub save {
		1384	my ($self) = @_;
		1385
		1386	my $lock = cf::lock_acquire "map_data:" . $self->path;
		1387
		1388	$self->{last_save} = $cf::RUNTIME;
		1389
		1390	return unless $self->dirty;
		1391
		1392	my $save = $self->{path}->save_path; utf8::encode $save;
		1393	my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;
		1394
		1395	$self->{load_path} = $save;
		1396
		1397	return if $self->{deny_save};
		1398
		1399	local $self->{last_access} = $self->last_access;#d#
		1400
		1401	cf::async {
		1402	$_->contr->save for $self->players;
		1403	};
		1404
		1405	if ($uniq) {
		1406	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
		1407	$self->save_objects ($uniq, cf::IO_UNIQUES);
		1408	} else {
		1409	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);
		1410	}
		1411	}
		1412
		1413	sub swap_out {
		1414	my ($self) = @_;
		1415
		1416	# save first because save cedes
		1417	$self->save;
		1418
		1419	my $lock = cf::lock_acquire "map_data:" . $self->path;
		1420
		1421	return if $self->players;
		1422	return if $self->in_memory != cf::MAP_IN_MEMORY;
		1423	return if $self->{deny_save};
		1424
		1425	$self->clear;
		1426	$self->in_memory (cf::MAP_SWAPPED);
		1427	}
		1428
		1429	sub reset_at {
		1430	my ($self) = @_;
		1431
		1432	# TODO: safety, remove and allow resettable per-player maps
		1433	return 1e99 if $self->{path}{user_rel};
		1434	return 1e99 if $self->{deny_reset};
		1435
		1436	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
		1437	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
		1438
		1439	$time + $to
		1440	}
		1441
		1442	sub should_reset {
		1443	my ($self) = @_;
		1444
		1445	$self->reset_at <= $cf::RUNTIME
		1446	}
		1447
		1448	sub unlink_save {
		1449	my ($self) = @_;
		1450
		1451	utf8::encode (my $save = $self->{path}->save_path);
		1452	aioreq_pri 3; IO::AIO::aio_unlink $save;
		1453	aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
		1454	}
		1455
		1456	sub rename {
		1457	my ($self, $new_path) = @_;
		1458
		1459	$self->unlink_save;
		1460
		1461	delete $cf::MAP{$self->path};
		1462	$self->{path} = new cf::path $new_path;
		1463	$self->path ($self->{path}->as_string);
		1464	$cf::MAP{$self->path} = $self;
		1465
		1466	$self->save;
		1467	}
		1468
		1469	sub reset {
		1470	my ($self) = @_;
		1471
		1472	my $lock = cf::lock_acquire "map_data:" . $self->path;
		1473
		1474	return if $self->players;
		1475	return if $self->{path}{user_rel};#d#
		1476
		1477	warn "resetting map ", $self->path;#d#
		1478
		1479	delete $cf::MAP{$self->path};
		1480
		1481	$_->clear_links_to ($self) for values %cf::MAP;
		1482
		1483	$self->unlink_save;
		1484	$self->destroy;
		1485	}
		1486
		1487	my $nuke_counter = "aaaa";
		1488
		1489	sub nuke {
		1490	my ($self) = @_;
		1491
		1492	$self->{deny_save} = 1;
		1493	$self->reset_timeout (1);
		1494	$self->rename ("{nuke}/" . ($nuke_counter++));
		1495	$self->reset; # polite request, might not happen
		1496	}
		1497
		1498	sub customise_for {
		1499	my ($map, $ob) = @_;
		1500
		1501	if ($map->per_player) {
		1502	return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};
		1503	}
		1504
		1505	$map
		1506	}
		1507
		1508	sub emergency_save {
		1509	my $freeze_guard = cf::freeze_mainloop;
		1510
		1511	warn "enter emergency perl save\n";
		1512
		1513	cf::sync_job {
		1514	warn "begin emergency player save\n";
		1515	$_->save for values %cf::PLAYER;
		1516	warn "end emergency player save\n";
		1517
		1518	warn "begin emergency map save\n";
		1519	$_->save for values %cf::MAP;
		1520	warn "end emergency map save\n";
		1521	};
		1522
		1523	warn "leave emergency perl save\n";
		1524	}
		1525
		1526	package cf;
		1527
		1528	=back
		1529
1028		1530
1029	=head3 cf::object::player	1531	=head3 cf::object::player
1030		1532
1031	=over 4	1533	=over 4
1032		1534
…		…
1068	(ref $cf::CFG{"may_$access"}	1570	(ref $cf::CFG{"may_$access"}
1069	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}	1571	? scalar grep $self->name eq $_, @{$cf::CFG{"may_$access"}}
1070	: $cf::CFG{"may_$access"})	1572	: $cf::CFG{"may_$access"})
1071	}	1573	}
1072		1574
		1575	=item $player_object->enter_link
		1576
		1577	Freezes the player and moves him/her to a special map (C<{link}>).
		1578
		1579	The player should be reaosnably safe there for short amounts of time. You
		1580	I<MUST> call C<leave_link> as soon as possible, though.
		1581
		1582	=item $player_object->leave_link ($map, $x, $y)
		1583
		1584	Moves the player out of the specila link map onto the given map. If the
		1585	map is not valid (or omitted), the player will be moved back to the
		1586	location he/she was before the call to C<enter_link>, or, if that fails,
		1587	to the emergency map position.
		1588
		1589	Might block.
		1590
		1591	=cut
		1592
		1593	sub cf::object::player::enter_link {
		1594	my ($self) = @_;
		1595
		1596	$self->deactivate_recursive;
		1597
		1598	return if $self->map == $LINK_MAP;
		1599
		1600	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]
		1601	if $self->map;
		1602
		1603	$self->enter_map ($LINK_MAP, 20, 20);
		1604	}
		1605
		1606	sub cf::object::player::leave_link {
		1607	my ($self, $map, $x, $y) = @_;
		1608
		1609	my $link_pos = delete $self->{_link_pos};
		1610
		1611	unless ($map) {
		1612	# restore original map position
		1613	($map, $x, $y) = @{ $link_pos \|\| [] };
		1614	$map = cf::map::find $map;
		1615
		1616	unless ($map) {
		1617	($map, $x, $y) = @$EMERGENCY_POSITION;
		1618	$map = cf::map::find $map
		1619	or die "FATAL: cannot load emergency map\n";
		1620	}
		1621	}
		1622
		1623	($x, $y) = (-1, -1)
		1624	unless (defined $x) && (defined $y);
		1625
		1626	# use -1 or undef as default coordinates, not 0, 0
		1627	($x, $y) = ($map->enter_x, $map->enter_y)
		1628	if $x <=0 && $y <= 0;
		1629
		1630	$map->load;
		1631
		1632	return unless $self->contr->active;
		1633	$self->activate_recursive;
		1634	$self->enter_map ($map, $x, $y);
		1635	}
		1636
		1637	cf::player->attach (
		1638	on_logout => sub {
		1639	my ($pl) = @_;
		1640
		1641	# abort map switching before logout
		1642	if ($pl->ob->{_link_pos}) {
		1643	cf::sync_job {
		1644	$pl->ob->leave_link
		1645	};
		1646	}
		1647	},
		1648	on_login => sub {
		1649	my ($pl) = @_;
		1650
		1651	# try to abort aborted map switching on player login :)
		1652	# should happen only on crashes
		1653	if ($pl->ob->{_link_pos}) {
		1654	$pl->ob->enter_link;
		1655	(async {
		1656	# we need this sleep as the login has a concurrent enter_exit running
		1657	# and this sleep increases chances of the player not ending up in scorn
		1658	$pl->ob->reply (undef,
		1659	"There was an internal problem at your last logout, "
		1660	. "the server will try to bring you to your intended destination in a second.",
		1661	cf::NDI_RED);
		1662	Coro::Timer::sleep 1;
		1663	$pl->ob->leave_link;
		1664	})->prio (2);
		1665	}
		1666	},
		1667	);
		1668
		1669	=item $player_object->goto ($path, $x, $y)
		1670
		1671	=cut
		1672
		1673	sub cf::object::player::goto {
		1674	my ($self, $path, $x, $y) = @_;
		1675
		1676	$self->enter_link;
		1677
		1678	(async {
		1679	$path = new cf::path $path;
		1680
		1681	my $map = cf::map::find $path->as_string;
		1682	$map = $map->customise_for ($self) if $map;
		1683
		1684	# warn "entering ", $map->path, " at ($x, $y)\n"
		1685	# if $map;
		1686
		1687	$map or $map->cluck ("oy");#d#
		1688	$map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE \| cf::NDI_RED);
		1689
		1690	$self->leave_link ($map, $x, $y);
		1691	})->prio (1);
		1692	}
		1693
		1694	=item $player_object->enter_exit ($exit_object)
		1695
		1696	=cut
		1697
		1698	sub parse_random_map_params {
		1699	my ($spec) = @_;
		1700
		1701	my $rmp = { # defaults
		1702	xsize => 10,
		1703	ysize => 10,
		1704	};
		1705
		1706	for (split /\n/, $spec) {
		1707	my ($k, $v) = split /\s+/, $_, 2;
		1708
		1709	$rmp->{lc $k} = $v if (length $k) && (length $v);
		1710	}
		1711
		1712	$rmp
		1713	}
		1714
		1715	sub prepare_random_map {
		1716	my ($exit) = @_;
		1717
		1718	# all this does is basically replace the /! path by
		1719	# a new random map path (?random/...) with a seed
		1720	# that depends on the exit object
		1721
		1722	my $rmp = parse_random_map_params $exit->msg;
		1723
		1724	if ($exit->map) {
		1725	$rmp->{region} = $exit->map->region_name;
		1726	$rmp->{origin_map} = $exit->map->path;
		1727	$rmp->{origin_x} = $exit->x;
		1728	$rmp->{origin_y} = $exit->y;
		1729	}
		1730
		1731	$rmp->{random_seed} \|\|= $exit->random_seed;
		1732
		1733	my $data = cf::to_json $rmp;
		1734	my $md5 = Digest::MD5::md5_hex $data;
		1735
		1736	if (my $fh = aio_open "$cf::RANDOM_MAPS/$md5.meta", O_WRONLY \| O_CREAT, 0666) {
		1737	aio_write $fh, 0, (length $data), $data, 0;
		1738
		1739	$exit->slaying ("?random/$md5");
		1740	$exit->msg (undef);
		1741	}
		1742	}
		1743
		1744	sub cf::object::player::enter_exit {
		1745	my ($self, $exit) = @_;
		1746
		1747	return unless $self->type == cf::PLAYER;
		1748
		1749	$self->enter_link;
		1750
		1751	(async {
		1752	$self->deactivate_recursive; # just to be sure
		1753	unless (eval {
		1754	prepare_random_map $exit
		1755	if $exit->slaying eq "/!";
		1756
		1757	my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;
		1758	$self->goto ($path, $exit->stats->hp, $exit->stats->sp);
		1759
		1760	1;
		1761	}) {
		1762	$self->message ("Something went wrong deep within the crossfire server. "
		1763	. "I'll try to bring you back to the map you were before. "
		1764	. "Please report this to the dungeon master",
		1765	cf::NDI_UNIQUE \| cf::NDI_RED);
		1766
		1767	warn "ERROR in enter_exit: $@";
		1768	$self->leave_link;
		1769	}
		1770	})->prio (1);
		1771	}
		1772
1073	=head3 cf::client	1773	=head3 cf::client
1074		1774
1075	=over 4	1775	=over 4
1076		1776
1077	=item $client->send_drawinfo ($text, $flags)	1777	=item $client->send_drawinfo ($text, $flags)
…		…
1120	on_reply => sub {	1820	on_reply => sub {
1121	my ($ns, $msg) = @_;	1821	my ($ns, $msg) = @_;
1122		1822
1123	# this weird shuffling is so that direct followup queries	1823	# this weird shuffling is so that direct followup queries
1124	# get handled first	1824	# get handled first
1125	my $queue = delete $ns->{query_queue};	1825	my $queue = delete $ns->{query_queue}
		1826	or return; # be conservative, not sure how that can happen, but we saw a crash here
1126		1827
1127	(shift @$queue)->[1]->($msg);	1828	(shift @$queue)->[1]->($msg);
1128		1829
1129	push @{ $ns->{query_queue} }, @$queue;	1830	push @{ $ns->{query_queue} }, @$queue;
1130		1831
…		…
1136	}	1837	}
1137	}	1838	}
1138	},	1839	},
1139	);	1840	);
1140		1841
1141	=item $client->coro (\&cb)	1842	=item $client->async (\&cb)
1142		1843
1143	Create a new coroutine, running the specified callback. The coroutine will	1844	Create a new coroutine, running the specified callback. The coroutine will
1144	be automatically cancelled when the client gets destroyed (e.g. on logout,	1845	be automatically cancelled when the client gets destroyed (e.g. on logout,
1145	or loss of connection).	1846	or loss of connection).
1146		1847
1147	=cut	1848	=cut
1148		1849
1149	sub cf::client::coro {	1850	sub cf::client::async {
1150	my ($self, $cb) = @_;	1851	my ($self, $cb) = @_;
1151		1852
1152	my $coro; $coro = async {	1853	my $coro = &Coro::async ($cb);
1153	eval {
1154	$cb->();
1155	};
1156	warn $@ if $@;
1157	};
1158		1854
1159	$coro->on_destroy (sub {	1855	$coro->on_destroy (sub {
1160	delete $self->{_coro}{$coro+0};	1856	delete $self->{_coro}{$coro+0};
1161	});	1857	});
1162		1858
…		…
1334		2030
1335	{	2031	{
1336	my $path = cf::localdir . "/database.pst";	2032	my $path = cf::localdir . "/database.pst";
1337		2033
1338	sub db_load() {	2034	sub db_load() {
1339	warn "loading database $path\n";#d# remove later
1340	$DB = stat $path ? Storable::retrieve $path : { };	2035	$DB = stat $path ? Storable::retrieve $path : { };
1341	}	2036	}
1342		2037
1343	my $pid;	2038	my $pid;
1344		2039
1345	sub db_save() {	2040	sub db_save() {
1346	warn "saving database $path\n";#d# remove later
1347	waitpid $pid, 0 if $pid;	2041	waitpid $pid, 0 if $pid;
1348	if (0 == ($pid = fork)) {	2042	if (0 == ($pid = fork)) {
1349	$DB->{_meta}{version} = 1;	2043	$DB->{_meta}{version} = 1;
1350	Storable::nstore $DB, "$path~";	2044	Storable::nstore $DB, "$path~";
1351	rename "$path~", $path;	2045	rename "$path~", $path;
…		…
1399	open my $fh, "<:utf8", cf::confdir . "/config"	2093	open my $fh, "<:utf8", cf::confdir . "/config"
1400	or return;	2094	or return;
1401		2095
1402	local $/;	2096	local $/;
1403	*CFG = YAML::Syck::Load <$fh>;	2097	*CFG = YAML::Syck::Load <$fh>;
		2098
		2099	$EMERGENCY_POSITION = $CFG{emergency_position} \|\| ["/world/world_105_115", 5, 37];
		2100
		2101	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};
		2102	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
		2103
		2104	if (exists $CFG{mlockall}) {
		2105	eval {
		2106	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
		2107	and die "WARNING: m(un)lockall failed: $!\n";
		2108	};
		2109	warn $@ if $@;
		2110	}
1404	}	2111	}
1405		2112
1406	sub main {	2113	sub main {
1407	# we must not ever block the main coroutine	2114	# we must not ever block the main coroutine
1408	local $Coro::idle = sub {	2115	local $Coro::idle = sub {
1409	Carp::cluck "FATAL: Coro::idle was called, major BUG\n";#d#	2116	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
1410	(Coro::unblock_sub {
1411	Event::one_event;	2117	async { Event::one_event };
1412	})->();
1413	};	2118	};
1414		2119
1415	cfg_load;	2120	cfg_load;
1416	db_load;	2121	db_load;
1417	load_extensions;	2122	load_extensions;
…		…
1419	}	2124	}
1420		2125
1421	#############################################################################	2126	#############################################################################
1422	# initialisation	2127	# initialisation
1423		2128
1424	sub perl_reload() {	2129	sub reload() {
1425	# can/must only be called in main	2130	# can/must only be called in main
1426	if ($Coro::current != $Coro::main) {	2131	if ($Coro::current != $Coro::main) {
1427	warn "can only reload from main coroutine\n";	2132	warn "can only reload from main coroutine\n";
1428	return;	2133	return;
1429	}	2134	}
1430		2135
1431	warn "reloading...";	2136	warn "reloading...";
1432		2137
1433	local $FREEZE = 1;	2138	my $guard = freeze_mainloop;
1434	cf::emergency_save;	2139	cf::emergency_save;
1435		2140
1436	eval {	2141	eval {
1437	# if anything goes wrong in here, we should simply crash as we already saved	2142	# if anything goes wrong in here, we should simply crash as we already saved
1438		2143
…		…
1500	cf::load_extensions;	2205	cf::load_extensions;
1501		2206
1502	# reattach attachments to objects	2207	# reattach attachments to objects
1503	warn "reattach";	2208	warn "reattach";
1504	_global_reattach;	2209	_global_reattach;
		2210	reattach $_ for values %MAP;
1505	};	2211	};
1506		2212
1507	if ($@) {	2213	if ($@) {
1508	warn $@;	2214	warn $@;
1509	warn "error while reloading, exiting.";	2215	warn "error while reloading, exiting.";
…		…
1522	$LINK_MAP->height (41);	2228	$LINK_MAP->height (41);
1523	$LINK_MAP->alloc;	2229	$LINK_MAP->alloc;
1524	$LINK_MAP->path ("{link}");	2230	$LINK_MAP->path ("{link}");
1525	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";	2231	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
1526	$LINK_MAP->in_memory (MAP_IN_MEMORY);	2232	$LINK_MAP->in_memory (MAP_IN_MEMORY);
		2233
		2234	# dirty hack because... archetypes are not yet loaded
		2235	Event->timer (
		2236	after => 10,
		2237	cb => sub {
		2238	$_[0]->w->cancel;
		2239
		2240	# provide some exits "home"
		2241	my $exit = cf::object::new "exit";
		2242
		2243	$exit->slaying ($EMERGENCY_POSITION->[0]);
		2244	$exit->stats->hp ($EMERGENCY_POSITION->[1]);
		2245	$exit->stats->sp ($EMERGENCY_POSITION->[2]);
		2246
		2247	$LINK_MAP->insert ($exit->clone, 19, 19);
		2248	$LINK_MAP->insert ($exit->clone, 19, 20);
		2249	$LINK_MAP->insert ($exit->clone, 19, 21);
		2250	$LINK_MAP->insert ($exit->clone, 20, 19);
		2251	$LINK_MAP->insert ($exit->clone, 20, 21);
		2252	$LINK_MAP->insert ($exit->clone, 21, 19);
		2253	$LINK_MAP->insert ($exit->clone, 21, 20);
		2254	$LINK_MAP->insert ($exit->clone, 21, 21);
		2255
		2256	$exit->destroy;
		2257	});
		2258
		2259	$LINK_MAP->{deny_save} = 1;
		2260	$LINK_MAP->{deny_reset} = 1;
		2261
		2262	$cf::MAP{$LINK_MAP->path} = $LINK_MAP;
1527	}	2263	}
1528		2264
1529	register "<global>", __PACKAGE__;	2265	register "<global>", __PACKAGE__;
1530		2266
1531	register_command "perl-reload" => sub {	2267	register_command "reload" => sub {
1532	my ($who, $arg) = @_;	2268	my ($who, $arg) = @_;
1533		2269
1534	if ($who->flag (FLAG_WIZ)) {	2270	if ($who->flag (FLAG_WIZ)) {
1535	$who->message ("start of reload.");	2271	$who->message ("start of reload.");
1536	perl_reload;	2272	reload;
1537	$who->message ("end of reload.");	2273	$who->message ("end of reload.");
1538	}	2274	}
1539	};	2275	};
1540		2276
1541	unshift @INC, $LIBDIR;	2277	unshift @INC, $LIBDIR;
…		…
1544	reentrant => 0,	2280	reentrant => 0,
1545	prio => 0,	2281	prio => 0,
1546	at => $NEXT_TICK \|\| $TICK,	2282	at => $NEXT_TICK \|\| $TICK,
1547	data => WF_AUTOCANCEL,	2283	data => WF_AUTOCANCEL,
1548	cb => sub {	2284	cb => sub {
1549	unless ($FREEZE) {
1550	cf::server_tick; # one server iteration	2285	cf::server_tick; # one server iteration
1551	$RUNTIME += $TICK;	2286	$RUNTIME += $TICK;
1552	}
1553
1554	$NEXT_TICK += $TICK;	2287	$NEXT_TICK += $TICK;
1555		2288
1556	# if we are delayed by four ticks or more, skip them all	2289	# if we are delayed by four ticks or more, skip them all
1557	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	2290	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
1558		2291
…		…
1581	or warn "ERROR: unable to write runtime file: $!";	2314	or warn "ERROR: unable to write runtime file: $!";
1582	})->();	2315	})->();
1583	},	2316	},
1584	);	2317	);
1585		2318
		2319	END { cf::emergency_save }
		2320
1586	1	2321	1
1587		2322

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.151 by root, Mon Jan 8 20:59:15 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.151 by root, Mon Jan 8 20:59:15 2007 UTC