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

Comparing cf.schmorp.de/server/lib/cf.pm (file contents):
Revision 1.154 by root, Tue Jan 9 15:36:19 2007 UTC vs.
Revision 1.167 by root, Sat Jan 13 23:32:43 2007 UTC

…		…
24	use YAML::Syck ();	24	use YAML::Syck ();
25	use Time::HiRes;	25	use Time::HiRes;
26		26
27	use Event; $Event::Eval = 1; # no idea why this is required, but it is	27	use Event; $Event::Eval = 1; # no idea why this is required, but it is
28		28
		29	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
		30
29	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?	31	# work around bug in YAML::Syck - bad news for perl6, will it be as broken wrt. unicode?
30	$YAML::Syck::ImplicitUnicode = 1;	32	$YAML::Syck::ImplicitUnicode = 1;
31		33
32	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority	34	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
33		35
34	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
35
36	our %COMMAND = ();	36	our %COMMAND = ();
37	our %COMMAND_TIME = ();	37	our %COMMAND_TIME = ();
		38
		39	our @EXTS = (); # list of extension package names
38	our %EXTCMD = ();	40	our %EXTCMD = ();
		41	our %EXT_CORO = (); # coroutines bound to extensions
		42	our %EXT_MAP = (); # pluggable maps
39		43
40	our @EVENT;	44	our @EVENT;
41	our $LIBDIR = datadir . "/ext";	45	our $LIBDIR = datadir . "/ext";
42		46
43	our $TICK = MAX_TIME * 1e-6;	47	our $TICK = MAX_TIME * 1e-6;
…		…
50	our $UPTIME; $UPTIME \|\|= time;	54	our $UPTIME; $UPTIME \|\|= time;
51	our $RUNTIME;	55	our $RUNTIME;
52		56
53	our %PLAYER; # all users	57	our %PLAYER; # all users
54	our %MAP; # all maps	58	our %MAP; # all maps
55	our $LINK_MAP; # the special {link} map	59	our $LINK_MAP; # the special {link} map, which is always available
56	our $RANDOM_MAPS = cf::localdir . "/random";	60	our $RANDOM_MAPS = cf::localdir . "/random";
57	our %EXT_CORO; # coroutines bound to extensions	61
		62	our $WAIT_FOR_TICK; $WAIT_FOR_TICK \|\|= new Coro::Signal;
		63	our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE \|\|= new Coro::Signal;
		64
		65	# used to convert map paths into valid unix filenames by replacing / by ∕
		66	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
58		67
59	binmode STDOUT;	68	binmode STDOUT;
60	binmode STDERR;	69	binmode STDERR;
61		70
62	# read virtual server time, if available	71	# read virtual server time, if available
…		…
70	mkdir cf::localdir . "/" . cf::playerdir;	79	mkdir cf::localdir . "/" . cf::playerdir;
71	mkdir cf::localdir . "/" . cf::tmpdir;	80	mkdir cf::localdir . "/" . cf::tmpdir;
72	mkdir cf::localdir . "/" . cf::uniquedir;	81	mkdir cf::localdir . "/" . cf::uniquedir;
73	mkdir $RANDOM_MAPS;	82	mkdir $RANDOM_MAPS;
74		83
75	# a special map that is always available
76	our $LINK_MAP;
77	our $EMERGENCY_POSITION;	84	our $EMERGENCY_POSITION;
78		85
79	#############################################################################	86	#############################################################################
80		87
81	=head2 GLOBAL VARIABLES	88	=head2 GLOBAL VARIABLES
…		…
106		113
107	=item %cf::CFG	114	=item %cf::CFG
108		115
109	Configuration for the server, loaded from C</etc/crossfire/config>, or	116	Configuration for the server, loaded from C</etc/crossfire/config>, or
110	from wherever your confdir points to.	117	from wherever your confdir points to.
		118
		119	=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
		120
		121	These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
		122	or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
		123	processing has been done. Call C<< ->wait >> on them to maximise the
		124	window of cpu time available, or simply to synchronise to the server tick.
111		125
112	=back	126	=back
113		127
114	=cut	128	=cut
115		129
…		…
146	}	160	}
147		161
148	$Event::DIED = sub {	162	$Event::DIED = sub {
149	warn "error in event callback: @_";	163	warn "error in event callback: @_";
150	};	164	};
151
152	my %ext_pkg;
153	my @exts;
154	my @hook;
155		165
156	=head2 UTILITY FUNCTIONS	166	=head2 UTILITY FUNCTIONS
157		167
158	=over 4	168	=over 4
159		169
…		…
309	}	319	}
310	}	320	}
311		321
312	=item $coro = cf::async_ext { BLOCK }	322	=item $coro = cf::async_ext { BLOCK }
313		323
314	Like async, but this coro is automcatially being canceled when the	324	Like async, but this coro is automatically being canceled when the
315	extension calling this is being unloaded.	325	extension calling this is being unloaded.
316		326
317	=cut	327	=cut
318		328
319	sub async_ext(&) {	329	sub async_ext(&) {
…		…
328		338
329	$coro	339	$coro
330	}	340	}
331		341
332	sub write_runtime {	342	sub write_runtime {
		343	return unless $TICK_WATCHER->is_active;
		344
333	my $runtime = cf::localdir . "/runtime";	345	my $runtime = cf::localdir . "/runtime";
334		346
335	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644	347	my $fh = aio_open "$runtime~", O_WRONLY \| O_CREAT, 0644
336	or return;	348	or return;
337		349
…		…
352	}	364	}
353		365
354	=back	366	=back
355		367
356	=cut	368	=cut
357
358	#############################################################################
359
360	package cf::path;
361
362	# used to convert map paths into valid unix filenames by repalcing / by ∕
363	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
364
365	sub new {
366	my ($class, $path, $base) = @_;
367
368	$path = $path->as_string if ref $path;
369
370	my $self = bless { }, $class;
371
372	# {... are special paths that are not touched
373	# ?xxx/... are special absolute paths
374	# ?random/... random maps
375	# /! non-realised random map exit
376	# /... normal maps
377	# ~/... per-player maps without a specific player (DO NOT USE)
378	# ~user/... per-player map of a specific user
379
380	if ($path =~ /^{/) {
381	# fine as it is
382	} elsif ($path =~ s{^\?random/}{}) {
383	Coro::AIO::aio_load "$cf::RANDOM_MAPS/$path.meta", my $data;
384	$self->{random} = cf::from_json $data;
385	} else {
386	if ($path =~ s{^~([^/]+)?}{}) {
387	$self->{user_rel} = 1;
388
389	if (defined $1) {
390	$self->{user} = $1;
391	} elsif ($base =~ m{^~([^/]+)/}) {
392	$self->{user} = $1;
393	} else {
394	warn "cannot resolve user-relative path without user <$path,$base>\n";
395	}
396	} elsif ($path =~ /^\//) {
397	# already absolute
398	} else {
399	$base =~ s{[^/]+/?$}{};
400	return $class->new ("$base/$path");
401	}
402
403	for ($path) {
404	redo if s{/\.?/}{/};
405	redo if s{/[^/]+/\.\./}{/};
406	}
407	}
408
409	$self->{path} = $path;
410
411	$self
412	}
413
414	# the name / primary key / in-game path
415	sub as_string {
416	my ($self) = @_;
417
418	$self->{user_rel} ? "~$self->{user}$self->{path}"
419	: $self->{random} ? "?random/$self->{path}"
420	: $self->{path}
421	}
422
423	# the displayed name, this is a one way mapping
424	sub visible_name {
425	my ($self) = @_;
426
427	# if (my $rmp = $self->{random}) {
428	# # todo: be more intelligent about this
429	# "?random/$rmp->{origin_map}+$rmp->{origin_x}+$rmp->{origin_y}/$rmp->{dungeon_level}"
430	# } else {
431	$self->as_string
432	# }
433	}
434
435	# escape the /'s in the path
436	sub _escaped_path {
437	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
438	$path
439	}
440
441	# the original (read-only) location
442	sub load_path {
443	my ($self) = @_;
444
445	sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
446	}
447
448	# the temporary/swap location
449	sub save_path {
450	my ($self) = @_;
451
452	$self->{user_rel} ? sprintf "%s/%s/%s/%s", cf::localdir, cf::playerdir, $self->{user}, $self->_escaped_path
453	: $self->{random} ? sprintf "%s/%s", $RANDOM_MAPS, $self->{path}
454	: sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $self->_escaped_path
455	}
456
457	# the unique path, might be eq to save_path
458	sub uniq_path {
459	my ($self) = @_;
460
461	$self->{user_rel} \|\| $self->{random}
462	? undef
463	: sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $self->_escaped_path
464	}
465
466	# return random map parameters, or undef
467	sub random_map_params {
468	my ($self) = @_;
469
470	$self->{random}
471	}
472
473	# this is somewhat ugly, but style maps do need special treatment
474	sub is_style_map {
475	$_[0]{path} =~ m{^/styles/}
476	}
477
478	package cf;
479		369
480	#############################################################################	370	#############################################################################
481		371
482	=head2 ATTACHABLE OBJECTS	372	=head2 ATTACHABLE OBJECTS
483		373
…		…
930	=cut	820	=cut
931		821
932	sub register_extcmd {	822	sub register_extcmd {
933	my ($name, $cb) = @_;	823	my ($name, $cb) = @_;
934		824
935	my $caller = caller;
936	#warn "registering extcmd '$name' to '$caller'";
937
938	$EXTCMD{$name} = [$cb, $caller];	825	$EXTCMD{$name} = $cb;
939	}	826	}
940		827
941	cf::player->attach (	828	cf::player->attach (
942	on_command => sub {	829	on_command => sub {
943	my ($pl, $name, $params) = @_;	830	my ($pl, $name, $params) = @_;
…		…
956		843
957	my $msg = eval { from_json $buf };	844	my $msg = eval { from_json $buf };
958		845
959	if (ref $msg) {	846	if (ref $msg) {
960	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	847	if (my $cb = $EXTCMD{$msg->{msgtype}}) {
961	if (my %reply = $cb->[0]->($pl, $msg)) {	848	if (my %reply = $cb->($pl, $msg)) {
962	$pl->ext_reply ($msg->{msgid}, %reply);	849	$pl->ext_reply ($msg->{msgid}, %reply);
963	}	850	}
964	}	851	}
965	} else {	852	} else {
966	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	853	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
…		…
968		855
969	cf::override;	856	cf::override;
970	},	857	},
971	);	858	);
972		859
973	sub register {
974	my ($base, $pkg) = @_;
975
976	#TODO
977	}
978
979	sub load_extension {	860	sub load_extension {
980	my ($path) = @_;	861	my ($path) = @_;
981		862
982	$path =~ /([^\/\\]+)\.ext$/ or die "$path";	863	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
983	my $base = $1;	864	my $base = $1;
984	my $pkg = $1;	865	my $pkg = $1;
985	$pkg =~ s/[^[:word:]]/_/g;	866	$pkg =~ s/[^[:word:]]/_/g;
986	$pkg = "ext::$pkg";	867	$pkg = "ext::$pkg";
987		868
988	warn "loading '$path' into '$pkg'\n";	869	warn "... loading '$path' into '$pkg'\n";
989		870
990	open my $fh, "<:utf8", $path	871	open my $fh, "<:utf8", $path
991	or die "$path: $!";	872	or die "$path: $!";
992		873
993	my $source =	874	my $source =
994	"package $pkg; use strict; use utf8;\n"	875	"package $pkg; use strict; use utf8;\n"
995	. "#line 1 \"$path\"\n{\n"	876	. "#line 1 \"$path\"\n{\n"
996	. (do { local $/; <$fh> })	877	. (do { local $/; <$fh> })
997	. "\n};\n1";	878	. "\n};\n1";
998		879
999	eval $source	880	unless (eval $source) {
1000	or die $@ ? "$path: $@\n"	881	my $msg = $@ ? "$path: $@\n"
1001	: "extension disabled.\n";	882	: "extension disabled.\n";
1002		883	if ($source =~ /^#!.perl.#.*MANDATORY/m) { # ugly match
1003	push @exts, $pkg;	884	warn $@;
1004	$ext_pkg{$base} = $pkg;	885	warn "mandatory extension failed to load, exiting.\n";
1005		886	exit 1;
1006	# no strict 'refs';	887	}
1007	# @{"$pkg\::ISA"} = ext::;	888	die $@;
1008
1009	register $base, $pkg;
1010	}
1011
1012	sub unload_extension {
1013	my ($pkg) = @_;
1014
1015	warn "removing extension $pkg\n";
1016
1017	# remove hooks
1018	#TODO
1019	# for my $idx (0 .. $#PLUGIN_EVENT) {
1020	# delete $hook[$idx]{$pkg};
1021	# }	889	}
1022		890
1023	# remove commands	891	push @EXTS, $pkg;
1024	for my $name (keys %COMMAND) {
1025	my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1026
1027	if (@cb) {
1028	$COMMAND{$name} = \@cb;
1029	} else {
1030	delete $COMMAND{$name};
1031	}
1032	}
1033
1034	# remove extcmds
1035	for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1036	delete $EXTCMD{$name};
1037	}
1038
1039	if (my $cb = $pkg->can ("unload")) {
1040	eval {
1041	$cb->($pkg);
1042	1
1043	} or warn "$pkg unloaded, but with errors: $@";
1044	}
1045
1046	Symbol::delete_package $pkg;
1047	}	892	}
1048		893
1049	sub load_extensions {	894	sub load_extensions {
1050	for my $ext (<$LIBDIR/*.ext>) {	895	for my $ext (<$LIBDIR/*.ext>) {
1051	next unless -r $ext;	896	next unless -r $ext;
…		…
1055	} or warn "$ext not loaded: $@";	900	} or warn "$ext not loaded: $@";
1056	}	901	}
1057	}	902	}
1058		903
1059	#############################################################################	904	#############################################################################
1060	# load/save/clean perl data associated with a map
1061
1062	*cf::mapsupport::on_clean = sub {
1063	my ($map) = @_;
1064
1065	my $path = $map->tmpname;
1066	defined $path or return;
1067
1068	unlink "$path.pst";
1069	};
1070
1071	cf::map->attach (prio => -10000, package => cf::mapsupport::);
1072
1073	#############################################################################
1074	# load/save perl data associated with player->ob objects
1075
1076	sub all_objects(@) {
1077	@_, map all_objects ($_->inv), @_
1078	}
1079
1080	# TODO: compatibility cruft, remove when no longer needed
1081	cf::player->attach (
1082	on_load => sub {
1083	my ($pl, $path) = @_;
1084
1085	for my $o (all_objects $pl->ob) {
1086	if (my $value = $o->get_ob_key_value ("_perl_data")) {
1087	$o->set_ob_key_value ("_perl_data");
1088
1089	%$o = %{ Storable::thaw pack "H*", $value };
1090	}
1091	}
1092	},
1093	);
1094
1095	#############################################################################
1096		905
1097	=head2 CORE EXTENSIONS	906	=head2 CORE EXTENSIONS
1098		907
1099	Functions and methods that extend core crossfire objects.	908	Functions and methods that extend core crossfire objects.
1100		909
…		…
1225	my @logins;	1034	my @logins;
1226		1035
1227	for my $login (@$dirs) {	1036	for my $login (@$dirs) {
1228	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1037	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
1229	aio_read $fh, 0, 512, my $buf, 0 or next;	1038	aio_read $fh, 0, 512, my $buf, 0 or next;
1230	$buf !~ /^password -------------$/ or next; # official not-valid tag	1039	$buf !~ /^password -------------$/m or next; # official not-valid tag
1231		1040
1232	utf8::decode $login;	1041	utf8::decode $login;
1233	push @logins, $login;	1042	push @logins, $login;
1234	}	1043	}
1235		1044
1236	\@logins	1045	\@logins
1237	}	1046	}
1238		1047
1239	=item $player->maps	1048	=item $player->maps
1240		1049
1241	Returns an arrayref of cf::path's of all maps that are private for this	1050	Returns an arrayref of map paths that are private for this
1242	player. May block.	1051	player. May block.
1243		1052
1244	=cut	1053	=cut
1245		1054
1246	sub maps($) {	1055	sub maps($) {
…		…
1252	my @paths;	1061	my @paths;
1253		1062
1254	for (@$files) {	1063	for (@$files) {
1255	utf8::decode $_;	1064	utf8::decode $_;
1256	next if /\.(?:pl\|pst)$/;	1065	next if /\.(?:pl\|pst)$/;
1257	next unless /^$PATH_SEP/;	1066	next unless /^$PATH_SEP/o;
1258		1067
1259	s/$PATH_SEP/\//g;	1068	s/\.map$//;
1260	push @paths, new cf::path "~" . $pl->ob->name . "/" . $_;	1069	push @paths, "~" . $pl->ob->name . "/" . $_;
1261	}	1070	}
1262		1071
1263	\@paths	1072	\@paths
1264	}	1073	}
1265		1074
…		…
1291	package cf::map;	1100	package cf::map;
1292		1101
1293	use Fcntl;	1102	use Fcntl;
1294	use Coro::AIO;	1103	use Coro::AIO;
1295		1104
		1105	use overload
		1106	'""' => \&as_string;
		1107
1296	our $MAX_RESET = 3600;	1108	our $MAX_RESET = 3600;
1297	our $DEFAULT_RESET = 3000;	1109	our $DEFAULT_RESET = 3000;
1298		1110
1299	sub generate_random_map {	1111	sub generate_random_map {
1300	my ($path, $rmp) = @_;	1112	my ($self, $rmp) = @_;
1301		1113
1302	# mit "rum" bekleckern, nicht	1114	# mit "rum" bekleckern, nicht
1303	cf::map::_create_random_map	1115	$self->_create_random_map (
1304	$path,
1305	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},	1116	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1306	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},	1117	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1307	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},	1118	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1308	$rmp->{exit_on_final_map},	1119	$rmp->{exit_on_final_map},
1309	$rmp->{xsize}, $rmp->{ysize},	1120	$rmp->{xsize}, $rmp->{ysize},
1310	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},	1121	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1311	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},	1122	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1312	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},	1123	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1313	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},	1124	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1314	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},	1125	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1315	(cf::region::find $rmp->{region})	1126	(cf::region::find $rmp->{region}), $rmp->{custom}
		1127	)
		1128	}
		1129
		1130	sub register {
		1131	my (undef, $regex) = @_;
		1132	my $pkg = caller;
		1133
		1134	no strict;
		1135	push @{"$pkg\::ISA"}, __PACKAGE__;
		1136
		1137	$EXT_MAP{$pkg} = qr<$regex>;
		1138	}
		1139
		1140	# also paths starting with '/'
		1141	$EXT_MAP{"cf::map"} = qr{^(?=/)};
		1142
		1143	sub normalise {
		1144	my ($path, $base) = @_;
		1145
		1146	# map plan:
		1147	#
		1148	# /! non-realised random map exit (special hack!)
		1149	# {... are special paths that are not being touched
		1150	# ?xxx/... are special absolute paths
		1151	# ?random/... random maps
		1152	# /... normal maps
		1153	# ~user/... per-player map of a specific user
		1154
		1155	$path =~ s/$PATH_SEP/\//go;
		1156
		1157	# treat it as relative path if it starts with
		1158	# something that looks reasonable
		1159	if ($path =~ m{^(?:\./\|\.\./\|\w)}) {
		1160	$base or Carp::carp "normalise called with relative path and no base: '$path'";
		1161
		1162	$base =~ s{[^/]+/?$}{};
		1163	$path = "$base/$path";
		1164	}
		1165
		1166	for ($path) {
		1167	redo if s{//}{/};
		1168	redo if s{/\.?/}{/};
		1169	redo if s{/[^/]+/\.\./}{/};
		1170	}
		1171
		1172	$path
		1173	}
		1174
		1175	sub new_from_path {
		1176	my (undef, $path, $base) = @_;
		1177
		1178	return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
		1179
		1180	$path = normalise $path, $base;
		1181
		1182	for my $pkg (keys %EXT_MAP) {
		1183	if ($path =~ $EXT_MAP{$pkg}) {
		1184	my $self = bless cf::map::new, $pkg;
		1185	$self->{path} = $path; $self->path ($path);
		1186	$self->init; # pass $1 etc.
		1187	return $self;
		1188	}
		1189	}
		1190
		1191	Carp::carp "unable to resolve path '$path'.";
		1192	()
		1193	}
		1194
		1195	sub init {
		1196	my ($self) = @_;
		1197
		1198	$self
		1199	}
		1200
		1201	sub as_string {
		1202	my ($self) = @_;
		1203
		1204	"$self->{path}"
		1205	}
		1206
		1207	# the displayed name, this is a one way mapping
		1208	sub visible_name {
		1209	&as_string
		1210	}
		1211
		1212	# the original (read-only) location
		1213	sub load_path {
		1214	my ($self) = @_;
		1215
		1216	sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
		1217	}
		1218
		1219	# the temporary/swap location
		1220	sub save_path {
		1221	my ($self) = @_;
		1222
		1223	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
		1224	sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path
		1225	}
		1226
		1227	# the unique path, undef == no special unique path
		1228	sub uniq_path {
		1229	my ($self) = @_;
		1230
		1231	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
		1232	sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1316	}	1233	}
1317		1234
1318	# and all this just because we cannot iterate over	1235	# and all this just because we cannot iterate over
1319	# all maps in C++...	1236	# all maps in C++...
1320	sub change_all_map_light {	1237	sub change_all_map_light {
…		…
1322		1239
1323	$_->change_map_light ($change)	1240	$_->change_map_light ($change)
1324	for grep $_->outdoor, values %cf::MAP;	1241	for grep $_->outdoor, values %cf::MAP;
1325	}	1242	}
1326		1243
		1244	sub unlink_save {
		1245	my ($self) = @_;
		1246
		1247	utf8::encode (my $save = $self->save_path);
		1248	IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save;
		1249	IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst";
		1250	}
		1251
1327	sub try_load_header($) {	1252	sub load_header_from($) {
1328	my ($path) = @_;	1253	my ($self, $path) = @_;
1329		1254
1330	utf8::encode $path;	1255	utf8::encode $path;
1331	aio_open $path, O_RDONLY, 0	1256	aio_open $path, O_RDONLY, 0
1332	or return;	1257	or return;
1333		1258
1334	my $map = cf::map::new	1259	$self->_load_header ($path)
1335	or return;	1260	or return;
1336		1261
1337	# for better error messages only, will be overwritten	1262	$self->{load_path} = $path;
1338	$map->path ($path);
1339		1263
1340	$map->load_header ($path)	1264	1
		1265	}
		1266
		1267	sub load_orig {
		1268	my ($self) = @_;
		1269
		1270	$self->load_header_from ($self->load_path)
		1271	}
		1272
		1273	sub load_temp {
		1274	my ($self) = @_;
		1275
		1276	$self->load_header_from ($self->save_path)
		1277	}
		1278
		1279	sub load_header {
		1280	my ($self) = @_;
		1281
		1282	if ($self->load_temp) {
		1283	$self->last_access ((delete $self->{last_access})
		1284	\|\| $cf::RUNTIME); #d#
		1285	# safety
		1286	$self->{instantiate_time} = $cf::RUNTIME
		1287	if $self->{instantiate_time} > $cf::RUNTIME;
		1288	} else {
		1289	$self->load_orig
1341	or return;	1290	or return;
1342		1291
1343	$map->{load_path} = $path;	1292	$self->{load_original} = 1;
		1293	$self->{instantiate_time} = $cf::RUNTIME;
		1294	$self->last_access ($cf::RUNTIME);
		1295	$self->instantiate;
		1296	}
1344		1297
1345	$map	1298	1
1346	}	1299	}
1347		1300
1348	sub find;	1301	sub find;
1349	sub find {	1302	sub find {
1350	my ($path, $origin) = @_;	1303	my ($path, $origin) = @_;
1351		1304
1352	#warn "find<$path,$origin>\n";#d#
1353
1354	$path = new cf::path $path, $origin && $origin->path;	1305	$path = normalise $path, $origin && $origin->path;
1355	my $key = $path->as_string;
1356		1306
1357	cf::lock_wait "map_find:$key";	1307	cf::lock_wait "map_find:$path";
1358		1308
1359	$cf::MAP{$key} \|\| do {	1309	$cf::MAP{$path} \|\| do {
1360	my $guard = cf::lock_acquire "map_find:$key";	1310	my $guard = cf::lock_acquire "map_find:$path";
1361		1311	my $map = new_from_path cf::map $path
1362	# do it the slow way
1363	my $map = try_load_header $path->save_path;
1364
1365	Coro::cede;
1366
1367	if ($map) {
1368	$map->last_access ((delete $map->{last_access})
1369	\|\| $cf::RUNTIME); #d#
1370	# safety
1371	$map->{instantiate_time} = $cf::RUNTIME
1372	if $map->{instantiate_time} > $cf::RUNTIME;
1373	} else {
1374	if (my $rmp = $path->random_map_params) {
1375	$map = generate_random_map $key, $rmp;
1376	} else {
1377	$map = try_load_header $path->load_path;
1378	}
1379
1380	$map or return;	1312	or return;
1381		1313
1382	$map->{load_original} = 1;
1383	$map->{instantiate_time} = $cf::RUNTIME;
1384	$map->last_access ($cf::RUNTIME);
1385	$map->instantiate;
1386
1387	# per-player maps become, after loading, normal maps
1388	$map->per_player (0) if $path->{user_rel};
1389	}
1390
1391	$map->path ($key);
1392	$map->{path} = $path;
1393	$map->{last_save} = $cf::RUNTIME;	1314	$map->{last_save} = $cf::RUNTIME;
1394		1315
1395	Coro::cede;	1316	$map->load_header
		1317	or return;
1396		1318
1397	if ($map->should_reset) {	1319	if ($map->should_reset) {
1398	$map->reset;	1320	$map->reset;
1399	undef $guard;	1321	undef $guard;
1400	$map = find $path	1322	$map = find $path
1401	or return;	1323	or return;
1402	}	1324	}
1403		1325
1404	$cf::MAP{$key} = $map	1326	$cf::MAP{$path} = $map
1405	}	1327	}
1406	}	1328	}
1407		1329
1408	sub load {	1330	sub load {
1409	my ($self) = @_;	1331	my ($self) = @_;
1410		1332
1411	my $path = $self->{path};	1333	my $path = $self->{path};
1412	my $guard = cf::lock_acquire "map_load:" . $path->as_string;	1334	my $guard = cf::lock_acquire "map_load:$path";
1413		1335
1414	return if $self->in_memory != cf::MAP_SWAPPED;	1336	return if $self->in_memory != cf::MAP_SWAPPED;
1415		1337
1416	$self->in_memory (cf::MAP_LOADING);	1338	$self->in_memory (cf::MAP_LOADING);
1417		1339
1418	$self->alloc;	1340	$self->alloc;
1419	$self->load_objects ($self->{load_path}, 1)	1341	$self->_load_objects ($self->{load_path}, 1)
1420	or return;	1342	or return;
1421		1343
1422	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1344	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1423	if delete $self->{load_original};	1345	if delete $self->{load_original};
1424		1346
1425	if (my $uniq = $path->uniq_path) {	1347	if (my $uniq = $self->uniq_path) {
1426	utf8::encode $uniq;	1348	utf8::encode $uniq;
1427	if (aio_open $uniq, O_RDONLY, 0) {	1349	if (aio_open $uniq, O_RDONLY, 0) {
1428	$self->clear_unique_items;	1350	$self->clear_unique_items;
1429	$self->load_objects ($uniq, 0);	1351	$self->_load_objects ($uniq, 0);
1430	}	1352	}
1431	}	1353	}
1432		1354
1433	Coro::cede;	1355	Coro::cede;
1434		1356
1435	# now do the right thing for maps	1357	# now do the right thing for maps
1436	$self->link_multipart_objects;	1358	$self->link_multipart_objects;
1437		1359
1438	if ($self->{path}->is_style_map) {	1360	unless ($self->{deny_activate}) {
1439	$self->{deny_save} = 1;	1361	$self->decay_objects;
1440	$self->{deny_reset} = 1;
1441	} else {
1442	$self->fix_auto_apply;	1362	$self->fix_auto_apply;
1443	$self->decay_objects;
1444	$self->update_buttons;	1363	$self->update_buttons;
		1364	Coro::cede;
1445	$self->set_darkness_map;	1365	$self->set_darkness_map;
1446	$self->difficulty ($self->estimate_difficulty)	1366	$self->difficulty ($self->estimate_difficulty)
1447	unless $self->difficulty;	1367	unless $self->difficulty;
		1368	Coro::cede;
1448	$self->activate;	1369	$self->activate;
1449	}	1370	}
1450		1371
1451	Coro::cede;
1452
1453	$self->in_memory (cf::MAP_IN_MEMORY);	1372	$self->in_memory (cf::MAP_IN_MEMORY);
		1373	}
		1374
		1375	sub customise_for {
		1376	my ($self, $ob) = @_;
		1377
		1378	return find "~" . $ob->name . "/" . $self->{path}
		1379	if $self->per_player;
		1380
		1381	$self
		1382	}
		1383
		1384	# find and load all maps in the 3x3 area around a map
		1385	sub load_diag {
		1386	my ($map) = @_;
		1387
		1388	my @diag; # diagonal neighbours
		1389
		1390	for (0 .. 3) {
		1391	my $neigh = $map->tile_path ($_)
		1392	or next;
		1393	$neigh = find $neigh, $map
		1394	or next;
		1395	$neigh->load;
		1396
		1397	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
		1398	[$neigh->tile_path (($_ + 1) % 4), $neigh];
		1399	}
		1400
		1401	for (@diag) {
		1402	my $neigh = find @$_
		1403	or next;
		1404	$neigh->load;
		1405	}
1454	}	1406	}
1455		1407
1456	sub find_sync {	1408	sub find_sync {
1457	my ($path, $origin) = @_;	1409	my ($path, $origin) = @_;
1458		1410
1459	cf::sync_job { cf::map::find $path, $origin }	1411	cf::sync_job { find $path, $origin }
1460	}	1412	}
1461		1413
1462	sub do_load_sync {	1414	sub do_load_sync {
1463	my ($map) = @_;	1415	my ($map) = @_;
1464		1416
1465	cf::sync_job { $map->load };	1417	cf::sync_job { $map->load };
1466	}	1418	}
1467		1419
		1420	our %MAP_PREFETCH;
		1421	our $MAP_PREFETCHER = Coro::async {
		1422	while () {
		1423	for my $path (keys %MAP_PREFETCH) {
		1424	my $map = find $path
		1425	or next;
		1426	$map->load;
		1427
		1428	delete $MAP_PREFETCH{$path};
		1429	}
		1430	Coro::schedule;
		1431	}
		1432	};
		1433
		1434	sub find_async {
		1435	my ($path, $origin) = @_;
		1436
		1437	$path = normalise $path, $origin && $origin->{path};
		1438
		1439	if (my $map = $cf::MAP{$path}) {
		1440	return $map if $map->in_memory == cf::MAP_IN_MEMORY;
		1441	}
		1442
		1443	$MAP_PREFETCH{$path} = 0;
		1444	$MAP_PREFETCHER->ready;
		1445
		1446	()
		1447	}
		1448
1468	sub save {	1449	sub save {
1469	my ($self) = @_;	1450	my ($self) = @_;
1470		1451
1471	my $lock = cf::lock_acquire "map_data:" . $self->path;	1452	my $lock = cf::lock_acquire "map_data:" . $self->path;
1472		1453
1473	$self->{last_save} = $cf::RUNTIME;	1454	$self->{last_save} = $cf::RUNTIME;
1474		1455
1475	return unless $self->dirty;	1456	return unless $self->dirty;
1476		1457
1477	my $save = $self->{path}->save_path; utf8::encode $save;	1458	my $save = $self->save_path; utf8::encode $save;
1478	my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;	1459	my $uniq = $self->uniq_path; utf8::encode $uniq;
1479		1460
1480	$self->{load_path} = $save;	1461	$self->{load_path} = $save;
1481		1462
1482	return if $self->{deny_save};	1463	return if $self->{deny_save};
1483		1464
…		…
1486	cf::async {	1467	cf::async {
1487	$_->contr->save for $self->players;	1468	$_->contr->save for $self->players;
1488	};	1469	};
1489		1470
1490	if ($uniq) {	1471	if ($uniq) {
1491	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);	1472	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
1492	$self->save_objects ($uniq, cf::IO_UNIQUES);	1473	$self->_save_objects ($uniq, cf::IO_UNIQUES);
1493	} else {	1474	} else {
1494	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);	1475	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);
1495	}	1476	}
1496	}	1477	}
1497		1478
1498	sub swap_out {	1479	sub swap_out {
1499	my ($self) = @_;	1480	my ($self) = @_;
…		…
1513		1494
1514	sub reset_at {	1495	sub reset_at {
1515	my ($self) = @_;	1496	my ($self) = @_;
1516		1497
1517	# TODO: safety, remove and allow resettable per-player maps	1498	# TODO: safety, remove and allow resettable per-player maps
1518	return 1e99 if $self->{path}{user_rel};	1499	return 1e99 if $self->isa ("ext::map_per_player");
1519	return 1e99 if $self->{deny_reset};	1500	return 1e99 if $self->{deny_reset};
1520		1501
1521	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;	1502	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1522	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;	1503	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
1523		1504
…		…
1528	my ($self) = @_;	1509	my ($self) = @_;
1529		1510
1530	$self->reset_at <= $cf::RUNTIME	1511	$self->reset_at <= $cf::RUNTIME
1531	}	1512	}
1532		1513
1533	sub unlink_save {
1534	my ($self) = @_;
1535
1536	utf8::encode (my $save = $self->{path}->save_path);
1537	aioreq_pri 3; IO::AIO::aio_unlink $save;
1538	aioreq_pri 3; IO::AIO::aio_unlink "$save.pst";
1539	}
1540
1541	sub rename {	1514	sub rename {
1542	my ($self, $new_path) = @_;	1515	my ($self, $new_path) = @_;
1543		1516
		1517	normalise $new_path;
		1518
1544	$self->unlink_save;	1519	$self->unlink_save;
1545		1520
1546	delete $cf::MAP{$self->path};	1521	delete $cf::MAP{$self->path};
1547	$self->{path} = new cf::path $new_path;	1522	$self->{path} = $new_path; $self->path ($self->{path});
1548	$self->path ($self->{path}->as_string);
1549	$cf::MAP{$self->path} = $self;	1523	$cf::MAP{$self->path} = $self;
1550		1524
1551	$self->save;	1525	$self->save;
1552	}	1526	}
1553		1527
1554	sub reset {	1528	sub reset {
1555	my ($self) = @_;	1529	my ($self) = @_;
1556		1530
1557	my $lock = cf::lock_acquire "map_data:" . $self->path;	1531	my $lock = cf::lock_acquire "map_data:$self->{path}";
1558		1532
1559	return if $self->players;	1533	return if $self->players;
1560	return if $self->{path}{user_rel};#d#	1534	return if $self->isa ("ext::map_per_player");#d#
1561		1535
1562	warn "resetting map ", $self->path;#d#	1536	warn "resetting map ", $self->path;#d#
1563		1537
1564	delete $cf::MAP{$self->path};	1538	delete $cf::MAP{$self->path};
		1539
		1540	$self->in_memory (cf::MAP_SWAPPED);
		1541	$self->clear;
1565		1542
1566	$_->clear_links_to ($self) for values %cf::MAP;	1543	$_->clear_links_to ($self) for values %cf::MAP;
1567		1544
1568	$self->unlink_save;	1545	$self->unlink_save;
1569	$self->destroy;	1546	$self->destroy;
…		…
1578	$self->reset_timeout (1);	1555	$self->reset_timeout (1);
1579	$self->rename ("{nuke}/" . ($nuke_counter++));	1556	$self->rename ("{nuke}/" . ($nuke_counter++));
1580	$self->reset; # polite request, might not happen	1557	$self->reset; # polite request, might not happen
1581	}	1558	}
1582		1559
1583	sub customise_for {	1560	=item cf::map::unique_maps
1584	my ($map, $ob) = @_;
1585		1561
1586	if ($map->per_player) {	1562	Returns an arrayref of paths of all shared maps that have
1587	return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};	1563	instantiated unique items. May block.
1588	}
1589		1564
1590	$map	1565	=cut
1591	}
1592		1566
1593	sub emergency_save {	1567	sub unique_maps() {
1594	my $freeze_guard = cf::freeze_mainloop;	1568	my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
		1569	or return;
1595		1570
1596	warn "enter emergency perl save\n";	1571	my @paths;
1597		1572
1598	cf::sync_job {	1573	for (@$files) {
1599	warn "begin emergency player save\n";	1574	utf8::decode $_;
1600	$_->save for values %cf::PLAYER;	1575	next if /\.pst$/;
1601	warn "end emergency player save\n";	1576	next unless /^$PATH_SEP/o;
1602		1577
1603	warn "begin emergency map save\n";	1578	s/\.map$//;
1604	$_->save for values %cf::MAP;	1579	push @paths, $_;
1605	warn "end emergency map save\n";
1606	};	1580	}
1607		1581
1608	warn "leave emergency perl save\n";	1582	\@paths
1609	}	1583	}
1610		1584
1611	package cf;	1585	package cf;
1612		1586
1613	=back	1587	=back
1614		1588
		1589	=head3 cf::object
		1590
		1591	=cut
		1592
		1593	package cf::object;
		1594
		1595	=over 4
		1596
		1597	=item $ob->inv_recursive
		1598
		1599	Returns the inventory of the object _and_ their inventories, recursively.
		1600
		1601	=cut
		1602
		1603	sub inv_recursive_;
		1604	sub inv_recursive_ {
		1605	map { $_, inv_recursive_ $_->inv } @_
		1606	}
		1607
		1608	sub inv_recursive {
		1609	inv_recursive_ inv $_[0]
		1610	}
		1611
		1612	package cf;
		1613
		1614	=back
1615		1615
1616	=head3 cf::object::player	1616	=head3 cf::object::player
1617		1617
1618	=over 4	1618	=over 4
1619		1619
…		…
1659		1659
1660	=item $player_object->enter_link	1660	=item $player_object->enter_link
1661		1661
1662	Freezes the player and moves him/her to a special map (C<{link}>).	1662	Freezes the player and moves him/her to a special map (C<{link}>).
1663		1663
1664	The player should be reaosnably safe there for short amounts of time. You	1664	The player should be reasonably safe there for short amounts of time. You
1665	I<MUST> call C<leave_link> as soon as possible, though.	1665	I<MUST> call C<leave_link> as soon as possible, though.
1666		1666
		1667	Will never block.
		1668
1667	=item $player_object->leave_link ($map, $x, $y)	1669	=item $player_object->leave_link ($map, $x, $y)
1668		1670
1669	Moves the player out of the specila link map onto the given map. If the	1671	Moves the player out of the special C<{link}> map onto the specified
1670	map is not valid (or omitted), the player will be moved back to the	1672	map. If the map is not valid (or omitted), the player will be moved back
1671	location he/she was before the call to C<enter_link>, or, if that fails,	1673	to the location he/she was before the call to C<enter_link>, or, if that
1672	to the emergency map position.	1674	fails, to the emergency map position.
1673		1675
1674	Might block.	1676	Might block.
1675		1677
1676	=cut	1678	=cut
		1679
		1680	sub link_map {
		1681	unless ($LINK_MAP) {
		1682	$LINK_MAP = cf::map::find "{link}"
		1683	or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 };
		1684	$LINK_MAP->load;
		1685	}
		1686
		1687	$LINK_MAP
		1688	}
1677		1689
1678	sub cf::object::player::enter_link {	1690	sub cf::object::player::enter_link {
1679	my ($self) = @_;	1691	my ($self) = @_;
1680		1692
1681	$self->deactivate_recursive;	1693	$self->deactivate_recursive;
1682		1694
1683	return if $self->map == $LINK_MAP;	1695	return if UNIVERSAL::isa $self->map, "ext::map_link";
1684		1696
1685	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]	1697	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]
1686	if $self->map;	1698	if $self->map;
1687		1699
1688	$self->enter_map ($LINK_MAP, 20, 20);	1700	$self->enter_map ($LINK_MAP \|\| link_map, 20, 20);
1689	}	1701	}
1690		1702
1691	sub cf::object::player::leave_link {	1703	sub cf::object::player::leave_link {
1692	my ($self, $map, $x, $y) = @_;	1704	my ($self, $map, $x, $y) = @_;
1693		1705
…		…
1711	# use -1 or undef as default coordinates, not 0, 0	1723	# use -1 or undef as default coordinates, not 0, 0
1712	($x, $y) = ($map->enter_x, $map->enter_y)	1724	($x, $y) = ($map->enter_x, $map->enter_y)
1713	if $x <=0 && $y <= 0;	1725	if $x <=0 && $y <= 0;
1714		1726
1715	$map->load;	1727	$map->load;
		1728	$map->load_diag;
1716		1729
1717	return unless $self->contr->active;	1730	return unless $self->contr->active;
1718	$self->activate_recursive;	1731	$self->activate_recursive;
1719	$self->enter_map ($map, $x, $y);	1732	$self->enter_map ($map, $x, $y);
1720	}	1733	}
…		…
1756	=cut	1769	=cut
1757		1770
1758	sub cf::object::player::goto {	1771	sub cf::object::player::goto {
1759	my ($self, $path, $x, $y) = @_;	1772	my ($self, $path, $x, $y) = @_;
1760		1773
1761	$path = new cf::path $path;
1762	$path ne "/" or Carp::cluck ("oy");#d#
1763
1764	$self->enter_link;	1774	$self->enter_link;
1765		1775
1766	(async {	1776	(async {
1767	my $map = cf::map::find $path->as_string;	1777	my $map = cf::map::find $path;
1768	$map = $map->customise_for ($self) if $map;	1778	$map = $map->customise_for ($self) if $map;
1769		1779
1770	# warn "entering ", $map->path, " at ($x, $y)\n"	1780	# warn "entering ", $map->path, " at ($x, $y)\n"
1771	# if $map;	1781	# if $map;
1772		1782
…		…
1837	$self->deactivate_recursive; # just to be sure	1847	$self->deactivate_recursive; # just to be sure
1838	unless (eval {	1848	unless (eval {
1839	prepare_random_map $exit	1849	prepare_random_map $exit
1840	if $exit->slaying eq "/!";	1850	if $exit->slaying eq "/!";
1841		1851
1842	my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;	1852	my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1843	$self->goto ($path, $exit->stats->hp, $exit->stats->sp);	1853	$self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1844		1854
1845	1;	1855	1;
1846	}) {	1856	}) {
1847	$self->message ("Something went wrong deep within the crossfire server. "	1857	$self->message ("Something went wrong deep within the crossfire server. "
1848	. "I'll try to bring you back to the map you were before. "	1858	. "I'll try to bring you back to the map you were before. "
1849	. "Please report this to the dungeon master",	1859	. "Please report this to the dungeon master!",
1850	cf::NDI_UNIQUE \| cf::NDI_RED);	1860	cf::NDI_UNIQUE \| cf::NDI_RED);
1851		1861
1852	warn "ERROR in enter_exit: $@";	1862	warn "ERROR in enter_exit: $@";
1853	$self->leave_link;	1863	$self->leave_link;
1854	}	1864	}
…		…
2207	load_extensions;	2217	load_extensions;
2208	Event::loop;	2218	Event::loop;
2209	}	2219	}
2210		2220
2211	#############################################################################	2221	#############################################################################
2212	# initialisation	2222	# initialisation and cleanup
		2223
		2224	# install some emergency cleanup handlers
		2225	BEGIN {
		2226	for my $signal (qw(INT HUP TERM)) {
		2227	Event->signal (
		2228	data => WF_AUTOCANCEL,
		2229	signal => $signal,
		2230	cb => sub {
		2231	cf::cleanup "SIG$signal";
		2232	},
		2233	);
		2234	}
		2235	}
		2236
		2237	sub emergency_save() {
		2238	my $freeze_guard = cf::freeze_mainloop;
		2239
		2240	warn "enter emergency perl save\n";
		2241
		2242	cf::sync_job {
		2243	# use a peculiar iteration method to avoid tripping on perl
		2244	# refcount bugs in for. also avoids problems with players
		2245	# and maps saved/destroyed asynchronously.
		2246	warn "begin emergency player save\n";
		2247	for my $login (keys %cf::PLAYER) {
		2248	my $pl = $cf::PLAYER{$login} or next;
		2249	$pl->valid or next;
		2250	$pl->save;
		2251	}
		2252	warn "end emergency player save\n";
		2253
		2254	warn "begin emergency map save\n";
		2255	for my $path (keys %cf::MAP) {
		2256	my $map = $cf::MAP{$path} or next;
		2257	$map->valid or next;
		2258	$map->save;
		2259	}
		2260	warn "end emergency map save\n";
		2261	};
		2262
		2263	warn "leave emergency perl save\n";
		2264	}
2213		2265
2214	sub reload() {	2266	sub reload() {
2215	# can/must only be called in main	2267	# can/must only be called in main
2216	if ($Coro::current != $Coro::main) {	2268	if ($Coro::current != $Coro::main) {
2217	warn "can only reload from main coroutine\n";	2269	warn "can only reload from main coroutine\n";
2218	return;	2270	return;
2219	}	2271	}
2220		2272
2221	warn "reloading...";	2273	warn "reloading...";
2222		2274
		2275	warn "freezing server";
2223	my $guard = freeze_mainloop;	2276	my $guard = freeze_mainloop;
2224	cf::emergency_save;	2277	cf::emergency_save;
2225		2278
		2279	warn "sync database to disk";
		2280	cf::db_sync;
		2281	IO::AIO::flush;
		2282
2226	eval {	2283	eval {
2227	# if anything goes wrong in here, we should simply crash as we already saved	2284	# if anything goes wrong in here, we should simply crash as we already saved
2228		2285
2229	# cancel all watchers	2286	warn "cancel all watchers";
2230	for (Event::all_watchers) {	2287	for (Event::all_watchers) {
2231	$_->cancel if $_->data & WF_AUTOCANCEL;	2288	$_->cancel if $_->data & WF_AUTOCANCEL;
2232	}	2289	}
2233		2290
2234	# cancel all extension coros	2291	warn "cancel all extension coros";
2235	$_->cancel for values %EXT_CORO;	2292	$_->cancel for values %EXT_CORO;
2236	%EXT_CORO = ();	2293	%EXT_CORO = ();
2237		2294
		2295	warn "remove commands";
		2296	%COMMAND = ();
		2297
		2298	warn "remove ext commands";
		2299	%EXTCMD = ();
		2300
2238	# unload all extensions	2301	warn "unload/nuke all extensions";
2239	for (@exts) {	2302	for my $pkg (@EXTS) {
2240	warn "unloading <$_>";	2303	warn "... unloading $pkg";
2241	unload_extension $_;	2304
		2305	if (my $cb = $pkg->can ("unload")) {
		2306	eval {
		2307	$cb->($pkg);
		2308	1
		2309	} or warn "$pkg unloaded, but with errors: $@";
2242	}	2310	}
2243		2311
		2312	warn "... nuking $pkg";
		2313	Symbol::delete_package $pkg;
		2314	}
		2315
2244	# unload all modules loaded from $LIBDIR	2316	warn "unload all perl modules loaded from $LIBDIR";
2245	while (my ($k, $v) = each %INC) {	2317	while (my ($k, $v) = each %INC) {
2246	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;	2318	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2247		2319
2248	warn "removing <$k>";	2320	warn "removing <$k>";
2249	delete $INC{$k};	2321	delete $INC{$k};
…		…
2256	}	2328	}
2257		2329
2258	Symbol::delete_package $k;	2330	Symbol::delete_package $k;
2259	}	2331	}
2260		2332
2261	# sync database to disk
2262	cf::db_sync;
2263	IO::AIO::flush;
2264
2265	# get rid of safe::, as good as possible	2333	warn "get rid of safe::, as good as possible";
2266	Symbol::delete_package "safe::$_"	2334	Symbol::delete_package "safe::$_"
2267	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	2335	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2268		2336
2269	# remove register_script_function callbacks
2270	# TODO
2271
2272	# unload cf.pm "a bit"	2337	warn "unload cf.pm \"a bit\"";
2273	delete $INC{"cf.pm"};	2338	delete $INC{"cf.pm"};
2274		2339
2275	# don't, removes xs symbols, too,	2340	# don't, removes xs symbols, too,
2276	# and global variables created in xs	2341	# and global variables created in xs
2277	#Symbol::delete_package __PACKAGE__;	2342	#Symbol::delete_package __PACKAGE__;
2278		2343
2279	# reload cf.pm
2280	warn "reloading cf.pm";	2344	warn "reloading cf.pm";
2281	require cf;	2345	require cf;
2282	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	2346	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2283		2347
2284	# load config and database again	2348	warn "load config and database again";
2285	cf::cfg_load;	2349	cf::cfg_load;
2286	cf::db_load;	2350	cf::db_load;
2287		2351
2288	# load extensions
2289	warn "load extensions";	2352	warn "load extensions";
2290	cf::load_extensions;	2353	cf::load_extensions;
2291		2354
2292	# reattach attachments to objects	2355	warn "reattach attachments to objects/players";
2293	warn "reattach";
2294	_global_reattach;	2356	_global_reattach;
		2357	warn "reattach attachments to maps";
2295	reattach $_ for values %MAP;	2358	reattach $_ for values %MAP;
2296	};	2359	};
2297		2360
2298	if ($@) {	2361	if ($@) {
2299	warn $@;	2362	warn $@;
2300	warn "error while reloading, exiting.";	2363	warn "error while reloading, exiting.";
2301	exit 1;	2364	exit 1;
2302	}	2365	}
2303		2366
2304	warn "reloaded successfully";	2367	warn "reloaded";
2305	};	2368	};
2306
2307	#############################################################################
2308
2309	unless ($LINK_MAP) {
2310	$LINK_MAP = cf::map::new;
2311
2312	$LINK_MAP->width (41);
2313	$LINK_MAP->height (41);
2314	$LINK_MAP->alloc;
2315	$LINK_MAP->path ("{link}");
2316	$LINK_MAP->{path} = bless { path => "{link}" }, "cf::path";
2317	$LINK_MAP->in_memory (MAP_IN_MEMORY);
2318
2319	# dirty hack because... archetypes are not yet loaded
2320	Event->timer (
2321	after => 10,
2322	cb => sub {
2323	$_[0]->w->cancel;
2324
2325	# provide some exits "home"
2326	my $exit = cf::object::new "exit";
2327
2328	$exit->slaying ($EMERGENCY_POSITION->[0]);
2329	$exit->stats->hp ($EMERGENCY_POSITION->[1]);
2330	$exit->stats->sp ($EMERGENCY_POSITION->[2]);
2331
2332	$LINK_MAP->insert ($exit->clone, 19, 19);
2333	$LINK_MAP->insert ($exit->clone, 19, 20);
2334	$LINK_MAP->insert ($exit->clone, 19, 21);
2335	$LINK_MAP->insert ($exit->clone, 20, 19);
2336	$LINK_MAP->insert ($exit->clone, 20, 21);
2337	$LINK_MAP->insert ($exit->clone, 21, 19);
2338	$LINK_MAP->insert ($exit->clone, 21, 20);
2339	$LINK_MAP->insert ($exit->clone, 21, 21);
2340
2341	$exit->destroy;
2342	});
2343
2344	$LINK_MAP->{deny_save} = 1;
2345	$LINK_MAP->{deny_reset} = 1;
2346
2347	$cf::MAP{$LINK_MAP->path} = $LINK_MAP;
2348	}
2349
2350	register "<global>", __PACKAGE__;
2351		2369
2352	register_command "reload" => sub {	2370	register_command "reload" => sub {
2353	my ($who, $arg) = @_;	2371	my ($who, $arg) = @_;
2354		2372
2355	if ($who->flag (FLAG_WIZ)) {	2373	if ($who->flag (FLAG_WIZ)) {
…		…
2365	reentrant => 0,	2383	reentrant => 0,
2366	prio => 0,	2384	prio => 0,
2367	at => $NEXT_TICK \|\| $TICK,	2385	at => $NEXT_TICK \|\| $TICK,
2368	data => WF_AUTOCANCEL,	2386	data => WF_AUTOCANCEL,
2369	cb => sub {	2387	cb => sub {
		2388	$NOW = Event::time;
		2389
2370	cf::server_tick; # one server iteration	2390	cf::server_tick; # one server iteration
2371	$RUNTIME += $TICK;	2391	$RUNTIME += $TICK;
2372	$NEXT_TICK += $TICK;	2392	$NEXT_TICK += $TICK;
		2393
		2394	$WAIT_FOR_TICK->broadcast;
		2395	$WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2373		2396
2374	# if we are delayed by four ticks or more, skip them all	2397	# if we are delayed by four ticks or more, skip them all
2375	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	2398	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2376		2399
2377	$TICK_WATCHER->at ($NEXT_TICK);	2400	$TICK_WATCHER->at ($NEXT_TICK);

Diff Legend

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

Comparing cf.schmorp.de/server/lib/cf.pm (file contents): Revision 1.154 by root, Tue Jan 9 15:36:19 2007 UTC vs. Revision 1.167 by root, Sat Jan 13 23:32:43 2007 UTC

Diff Legend

Comparing cf.schmorp.de/server/lib/cf.pm (file contents):
Revision 1.154 by root, Tue Jan 9 15:36:19 2007 UTC vs.
Revision 1.167 by root, Sat Jan 13 23:32:43 2007 UTC