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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.140 by root, Fri Jan 5 20:04:02 2007 UTC vs.
Revision 1.169 by root, Sun Jan 14 01:09:46 2007 UTC

…		…
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 Data::Dumper;
20	use Digest::MD5;	21	use Digest::MD5;
21	use Fcntl;	22	use Fcntl;
22	use IO::AIO 2.31 ();	23	use IO::AIO 2.32 ();
23	use YAML::Syck ();	24	use YAML::Syck ();
24	use Time::HiRes;	25	use Time::HiRes;
25		26
26	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
27		28
		29	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
		30
28	# 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?
29	$YAML::Syck::ImplicitUnicode = 1;	32	$YAML::Syck::ImplicitUnicode = 1;
30		33
31	$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
32		35
33	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
34
35	our %COMMAND = ();	36	our %COMMAND = ();
36	our %COMMAND_TIME = ();	37	our %COMMAND_TIME = ();
		38
		39	our @EXTS = (); # list of extension package names
37	our %EXTCMD = ();	40	our %EXTCMD = ();
		41	our %EXT_CORO = (); # coroutines bound to extensions
		42	our %EXT_MAP = (); # pluggable maps
38		43
39	our @EVENT;	44	our @EVENT;
40	our $LIBDIR = datadir . "/ext";	45	our $LIBDIR = datadir . "/ext";
41		46
42	our $TICK = MAX_TIME * 1e-6;	47	our $TICK = MAX_TIME * 1e-6;
43	our $TICK_WATCHER;	48	our $TICK_WATCHER;
		49	our $AIO_POLL_WATCHER;
		50	our $WRITE_RUNTIME_WATCHER;
44	our $NEXT_TICK;	51	our $NEXT_TICK;
45	our $NOW;	52	our $NOW;
46		53
47	our %CFG;	54	our %CFG;
48		55
49	our $UPTIME; $UPTIME \|\|= time;	56	our $UPTIME; $UPTIME \|\|= time;
50	our $RUNTIME;	57	our $RUNTIME;
51		58
		59	our %PLAYER; # all users
52	our %MAP; # all maps	60	our %MAP; # all maps
53	our $LINK_MAP; # the special {link} map	61	our $LINK_MAP; # the special {link} map, which is always available
54	our $RANDOM_MAPS = cf::localdir . "/random";	62	our $RANDOM_MAPS = cf::localdir . "/random";
55	our %EXT_CORO;	63
		64	our $WAIT_FOR_TICK; $WAIT_FOR_TICK \|\|= new Coro::Signal;
		65	our $WAIT_FOR_TICK_ONE; $WAIT_FOR_TICK_ONE \|\|= new Coro::Signal;
		66
		67	# used to convert map paths into valid unix filenames by replacing / by ∕
		68	our $PATH_SEP = "∕"; # U+2215, chosen purely for visual reasons
56		69
57	binmode STDOUT;	70	binmode STDOUT;
58	binmode STDERR;	71	binmode STDERR;
59		72
60	# read virtual server time, if available	73	# read virtual server time, if available
…		…
68	mkdir cf::localdir . "/" . cf::playerdir;	81	mkdir cf::localdir . "/" . cf::playerdir;
69	mkdir cf::localdir . "/" . cf::tmpdir;	82	mkdir cf::localdir . "/" . cf::tmpdir;
70	mkdir cf::localdir . "/" . cf::uniquedir;	83	mkdir cf::localdir . "/" . cf::uniquedir;
71	mkdir $RANDOM_MAPS;	84	mkdir $RANDOM_MAPS;
72		85
73	# a special map that is always available
74	our $LINK_MAP;
75	our $EMERGENCY_POSITION;	86	our $EMERGENCY_POSITION;
76		87
77	#############################################################################	88	#############################################################################
78		89
79	=head2 GLOBAL VARIABLES	90	=head2 GLOBAL VARIABLES
…		…
104		115
105	=item %cf::CFG	116	=item %cf::CFG
106		117
107	Configuration for the server, loaded from C</etc/crossfire/config>, or	118	Configuration for the server, loaded from C</etc/crossfire/config>, or
108	from wherever your confdir points to.	119	from wherever your confdir points to.
		120
		121	=item $cf::WAIT_FOR_TICK, $cf::WAIT_FOR_TICK_ONE
		122
		123	These are Coro::Signal objects that are C<< ->broadcast >> (WAIT_FOR_TICK)
		124	or C<< ->send >> (WAIT_FOR_TICK_ONE) on after normal server tick
		125	processing has been done. Call C<< ->wait >> on them to maximise the
		126	window of cpu time available, or simply to synchronise to the server tick.
109		127
110	=back	128	=back
111		129
112	=cut	130	=cut
113		131
…		…
117	utf8::encode $msg;	135	utf8::encode $msg;
118		136
119	$msg .= "\n"	137	$msg .= "\n"
120	unless $msg =~ /\n$/;	138	unless $msg =~ /\n$/;
121		139
122	LOG llevError, "cfperl: $msg";	140	LOG llevError, $msg;
123	};	141	};
124	}	142	}
125		143
126	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';	144	@safe::cf::global::ISA = @cf::global::ISA = 'cf::attachable';
127	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';	145	@safe::cf::object::ISA = @cf::object::ISA = 'cf::attachable';
…		…
145		163
146	$Event::DIED = sub {	164	$Event::DIED = sub {
147	warn "error in event callback: @_";	165	warn "error in event callback: @_";
148	};	166	};
149		167
150	my %ext_pkg;
151	my @exts;
152	my @hook;
153
154	=head2 UTILITY FUNCTIONS	168	=head2 UTILITY FUNCTIONS
155		169
156	=over 4	170	=over 4
157		171
		172	=item dumpval $ref
		173
158	=cut	174	=cut
		175
		176	sub dumpval {
		177	eval {
		178	local $SIG{__DIE__};
		179	my $d;
		180	if (1) {
		181	$d = new Data::Dumper([$_[0]], ["*var"]);
		182	$d->Terse(1);
		183	$d->Indent(2);
		184	$d->Quotekeys(0);
		185	$d->Useqq(1);
		186	#$d->Bless(...);
		187	$d->Seen($_[1]) if @_ > 1;
		188	$d = $d->Dump();
		189	}
		190	$d =~ s/([\x00-\x07\x09\x0b\x0c\x0e-\x1f])/sprintf "\\x%02x", ord($1)/ge;
		191	$d
		192	} \|\| "[unable to dump $_[0]: '$@']";
		193	}
159		194
160	use JSON::Syck (); # TODO# replace by JSON::PC once working	195	use JSON::Syck (); # TODO# replace by JSON::PC once working
161		196
162	=item $ref = cf::from_json $json	197	=item $ref = cf::from_json $json
163		198
…		…
224	}	259	}
225		260
226	sub freeze_mainloop {	261	sub freeze_mainloop {
227	return unless $TICK_WATCHER->is_active;	262	return unless $TICK_WATCHER->is_active;
228		263
229	my $guard = Coro::guard { $TICK_WATCHER->start };	264	my $guard = Coro::guard {
		265	$TICK_WATCHER->start;
		266	$WRITE_RUNTIME_WATCHER->start;
		267	};
		268	$WRITE_RUNTIME_WATCHER->stop;
230	$TICK_WATCHER->stop;	269	$TICK_WATCHER->stop;
231	$guard	270	$guard
232	}	271	}
233		272
234	=item cf::async { BLOCK }	273	=item cf::async { BLOCK }
…		…
273	warn $@ if $@;	312	warn $@ if $@;
274	undef $busy;	313	undef $busy;
275	})->prio (Coro::PRIO_MAX);	314	})->prio (Coro::PRIO_MAX);
276		315
277	while ($busy) {	316	while ($busy) {
278	unless (Coro::cede) {	317	Coro::cede or Event::one_event;
279	Coro::nready ? Event::one_event 0 : Event::one_event;
280	Coro::cede_notself unless Coro::cede;
281	}
282	}	318	}
283		319
284	wantarray ? @res : $res[0]	320	wantarray ? @res : $res[0]
285	} else {	321	} else {
286	# we are in another coroutine, how wonderful, everything just works	322	# we are in another coroutine, how wonderful, everything just works
…		…
289	}	325	}
290	}	326	}
291		327
292	=item $coro = cf::async_ext { BLOCK }	328	=item $coro = cf::async_ext { BLOCK }
293		329
294	Like async, but this coro is automcatially being canceled when the	330	Like async, but this coro is automatically being canceled when the
295	extension calling this is being unloaded.	331	extension calling this is being unloaded.
296		332
297	=cut	333	=cut
298		334
299	sub async_ext(&) {	335	sub async_ext(&) {
…		…
332	}	368	}
333		369
334	=back	370	=back
335		371
336	=cut	372	=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;
457		373
458	#############################################################################	374	#############################################################################
459		375
460	=head2 ATTACHABLE OBJECTS	376	=head2 ATTACHABLE OBJECTS
461		377
…		…
767	# object support	683	# object support
768		684
769	sub reattach {	685	sub reattach {
770	# basically do the same as instantiate, without calling instantiate	686	# basically do the same as instantiate, without calling instantiate
771	my ($obj) = @_;	687	my ($obj) = @_;
		688
		689	bless $obj, ref $obj; # re-bless in case extensions have been reloaded
772		690
773	my $registry = $obj->registry;	691	my $registry = $obj->registry;
774		692
775	@$registry = ();	693	@$registry = ();
776		694
…		…
908	=cut	826	=cut
909		827
910	sub register_extcmd {	828	sub register_extcmd {
911	my ($name, $cb) = @_;	829	my ($name, $cb) = @_;
912		830
913	my $caller = caller;
914	#warn "registering extcmd '$name' to '$caller'";
915
916	$EXTCMD{$name} = [$cb, $caller];	831	$EXTCMD{$name} = $cb;
917	}	832	}
918		833
919	cf::player->attach (	834	cf::player->attach (
920	on_command => sub {	835	on_command => sub {
921	my ($pl, $name, $params) = @_;	836	my ($pl, $name, $params) = @_;
…		…
934		849
935	my $msg = eval { from_json $buf };	850	my $msg = eval { from_json $buf };
936		851
937	if (ref $msg) {	852	if (ref $msg) {
938	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	853	if (my $cb = $EXTCMD{$msg->{msgtype}}) {
939	if (my %reply = $cb->[0]->($pl, $msg)) {	854	if (my %reply = $cb->($pl, $msg)) {
940	$pl->ext_reply ($msg->{msgid}, %reply);	855	$pl->ext_reply ($msg->{msgid}, %reply);
941	}	856	}
942	}	857	}
943	} else {	858	} else {
944	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	859	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
…		…
946		861
947	cf::override;	862	cf::override;
948	},	863	},
949	);	864	);
950		865
951	sub register {
952	my ($base, $pkg) = @_;
953
954	#TODO
955	}
956
957	sub load_extension {	866	sub load_extension {
958	my ($path) = @_;	867	my ($path) = @_;
959		868
960	$path =~ /([^\/\\]+)\.ext$/ or die "$path";	869	$path =~ /([^\/\\]+)\.ext$/ or die "$path";
961	my $base = $1;	870	my $base = $1;
962	my $pkg = $1;	871	my $pkg = $1;
963	$pkg =~ s/[^[:word:]]/_/g;	872	$pkg =~ s/[^[:word:]]/_/g;
964	$pkg = "ext::$pkg";	873	$pkg = "ext::$pkg";
965		874
966	warn "loading '$path' into '$pkg'\n";	875	warn "... loading '$path' into '$pkg'\n";
967		876
968	open my $fh, "<:utf8", $path	877	open my $fh, "<:utf8", $path
969	or die "$path: $!";	878	or die "$path: $!";
970		879
971	my $source =	880	my $source =
972	"package $pkg; use strict; use utf8;\n"	881	"package $pkg; use strict; use utf8;\n"
973	. "#line 1 \"$path\"\n{\n"	882	. "#line 1 \"$path\"\n{\n"
974	. (do { local $/; <$fh> })	883	. (do { local $/; <$fh> })
975	. "\n};\n1";	884	. "\n};\n1";
976		885
977	eval $source	886	unless (eval $source) {
978	or die $@ ? "$path: $@\n"	887	my $msg = $@ ? "$path: $@\n"
979	: "extension disabled.\n";	888	: "extension disabled.\n";
980		889	if ($source =~ /^#!.perl.#.*MANDATORY/m) { # ugly match
981	push @exts, $pkg;	890	warn $@;
982	$ext_pkg{$base} = $pkg;	891	warn "mandatory extension failed to load, exiting.\n";
983		892	exit 1;
984	# no strict 'refs';	893	}
985	# @{"$pkg\::ISA"} = ext::;	894	die $@;
986
987	register $base, $pkg;
988	}
989
990	sub unload_extension {
991	my ($pkg) = @_;
992
993	warn "removing extension $pkg\n";
994
995	# remove hooks
996	#TODO
997	# for my $idx (0 .. $#PLUGIN_EVENT) {
998	# delete $hook[$idx]{$pkg};
999	# }	895	}
1000		896
1001	# remove commands	897	push @EXTS, $pkg;
1002	for my $name (keys %COMMAND) {
1003	my @cb = grep $_->[0] ne $pkg, @{ $COMMAND{$name} };
1004
1005	if (@cb) {
1006	$COMMAND{$name} = \@cb;
1007	} else {
1008	delete $COMMAND{$name};
1009	}
1010	}
1011
1012	# remove extcmds
1013	for my $name (grep $EXTCMD{$_}[1] eq $pkg, keys %EXTCMD) {
1014	delete $EXTCMD{$name};
1015	}
1016
1017	if (my $cb = $pkg->can ("unload")) {
1018	eval {
1019	$cb->($pkg);
1020	1
1021	} or warn "$pkg unloaded, but with errors: $@";
1022	}
1023
1024	Symbol::delete_package $pkg;
1025	}	898	}
1026		899
1027	sub load_extensions {	900	sub load_extensions {
1028	for my $ext (<$LIBDIR/*.ext>) {	901	for my $ext (<$LIBDIR/*.ext>) {
1029	next unless -r $ext;	902	next unless -r $ext;
…		…
1033	} or warn "$ext not loaded: $@";	906	} or warn "$ext not loaded: $@";
1034	}	907	}
1035	}	908	}
1036		909
1037	#############################################################################	910	#############################################################################
1038	# load/save/clean perl data associated with a map
1039
1040	*cf::mapsupport::on_clean = sub {
1041	my ($map) = @_;
1042
1043	my $path = $map->tmpname;
1044	defined $path or return;
1045
1046	unlink "$path.pst";
1047	};
1048
1049	cf::map->attach (prio => -10000, package => cf::mapsupport::);
1050
1051	#############################################################################
1052	# load/save perl data associated with player->ob objects
1053
1054	sub all_objects(@) {
1055	@_, map all_objects ($_->inv), @_
1056	}
1057
1058	# TODO: compatibility cruft, remove when no longer needed
1059	cf::player->attach (
1060	on_load => sub {
1061	my ($pl, $path) = @_;
1062
1063	for my $o (all_objects $pl->ob) {
1064	if (my $value = $o->get_ob_key_value ("_perl_data")) {
1065	$o->set_ob_key_value ("_perl_data");
1066
1067	%$o = %{ Storable::thaw pack "H*", $value };
1068	}
1069	}
1070	},
1071	);
1072
1073	#############################################################################
1074		911
1075	=head2 CORE EXTENSIONS	912	=head2 CORE EXTENSIONS
1076		913
1077	Functions and methods that extend core crossfire objects.	914	Functions and methods that extend core crossfire objects.
1078		915
		916	=cut
		917
		918	package cf::player;
		919
		920	use Coro::AIO;
		921
1079	=head3 cf::player	922	=head3 cf::player
1080		923
1081	=over 4	924	=over 4
1082		925
1083	=item cf::player::exists $login	926	=item cf::player::find $login
1084		927
1085	Returns true when the given account exists.	928	Returns the given player object, loading it if necessary (might block).
1086		929
1087	=cut	930	=cut
1088		931
1089	sub cf::player::exists($) {	932	sub playerdir($) {
1090	cf::player::find $_[0]	933	cf::localdir
1091	or -f sprintf "%s/%s/%s/%s.pl", cf::localdir, cf::playerdir, ($_[0]) x 2;	934	. "/"
		935	. cf::playerdir
		936	. "/"
		937	. (ref $_[0] ? $_[0]->ob->name : $_[0])
		938	}
		939
		940	sub path($) {
		941	my $login = ref $_[0] ? $_[0]->ob->name : $_[0];
		942
		943	(playerdir $login) . "/$login.pl"
		944	}
		945
		946	sub find_active($) {
		947	$cf::PLAYER{$_[0]}
		948	and $cf::PLAYER{$_[0]}->active
		949	and $cf::PLAYER{$_[0]}
		950	}
		951
		952	sub exists($) {
		953	my ($login) = @_;
		954
		955	$cf::PLAYER{$login}
		956	or cf::sync_job { !aio_stat $login }
		957	}
		958
		959	sub find($) {
		960	return $cf::PLAYER{$_[0]} \|\| do {
		961	my $login = $_[0];
		962
		963	my $guard = cf::lock_acquire "user_find:$login";
		964
		965	$cf::PLAYER{$_[0]} \|\| do {
		966	my $pl = load_pl path $login
		967	or return;
		968	$cf::PLAYER{$login} = $pl
		969	}
		970	}
		971	}
		972
		973	sub save($) {
		974	my ($pl) = @_;
		975
		976	return if $pl->{deny_save};
		977
		978	my $path = path $pl;
		979	my $guard = cf::lock_acquire "user_save:$path";
		980
		981	return if $pl->{deny_save};
		982
		983	aio_mkdir playerdir $pl, 0770;
		984	$pl->{last_save} = $cf::RUNTIME;
		985
		986	$pl->save_pl ($path);
		987	Coro::cede;
		988	}
		989
		990	sub new($) {
		991	my ($login) = @_;
		992
		993	my $self = create;
		994
		995	$self->ob->name ($login);
		996	$self->{deny_save} = 1;
		997
		998	$cf::PLAYER{$login} = $self;
		999
		1000	$self
		1001	}
		1002
		1003	=item $pl->quit_character
		1004
		1005	Nukes the player without looking back. If logged in, the connection will
		1006	be destroyed. May block for a long time.
		1007
		1008	=cut
		1009
		1010	sub quit_character {
		1011	my ($pl) = @_;
		1012
		1013	$pl->{deny_save} = 1;
		1014	$pl->password ("*"); # this should lock out the player until we nuked the dir
		1015
		1016	$pl->invoke (cf::EVENT_PLAYER_LOGOUT, 1) if $pl->active;
		1017	$pl->deactivate;
		1018	$pl->invoke (cf::EVENT_PLAYER_QUIT);
		1019	$pl->ns->destroy if $pl->ns;
		1020
		1021	my $path = playerdir $pl;
		1022	my $temp = "$path~$cf::RUNTIME~deleting~";
		1023	aio_rename $path, $temp;
		1024	delete $cf::PLAYER{$pl->ob->name};
		1025	$pl->destroy;
		1026	IO::AIO::aio_rmtree $temp;
		1027	}
		1028
		1029	=item cf::player::list_logins
		1030
		1031	Returns am arrayref of all valid playernames in the system, can take a
		1032	while and may block, so not sync_job-capable, ever.
		1033
		1034	=cut
		1035
		1036	sub list_logins {
		1037	my $dirs = aio_readdir cf::localdir . "/" . cf::playerdir
		1038	or return [];
		1039
		1040	my @logins;
		1041
		1042	for my $login (@$dirs) {
		1043	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;
		1044	aio_read $fh, 0, 512, my $buf, 0 or next;
		1045	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1046
		1047	utf8::decode $login;
		1048	push @logins, $login;
		1049	}
		1050
		1051	\@logins
		1052	}
		1053
		1054	=item $player->maps
		1055
		1056	Returns an arrayref of map paths that are private for this
		1057	player. May block.
		1058
		1059	=cut
		1060
		1061	sub maps($) {
		1062	my ($pl) = @_;
		1063
		1064	my $files = aio_readdir playerdir $pl
		1065	or return;
		1066
		1067	my @paths;
		1068
		1069	for (@$files) {
		1070	utf8::decode $_;
		1071	next if /\.(?:pl\|pst)$/;
		1072	next unless /^$PATH_SEP/o;
		1073
		1074	s/\.map$//;
		1075	push @paths, "~" . $pl->ob->name . "/" . $_;
		1076	}
		1077
		1078	\@paths
1092	}	1079	}
1093		1080
1094	=item $player->ext_reply ($msgid, $msgtype, %msg)	1081	=item $player->ext_reply ($msgid, $msgtype, %msg)
1095		1082
1096	Sends an ext reply to the player.	1083	Sends an ext reply to the player.
1097		1084
1098	=cut	1085	=cut
1099		1086
1100	sub cf::player::ext_reply($$$%) {	1087	sub ext_reply($$$%) {
1101	my ($self, $id, %msg) = @_;	1088	my ($self, $id, %msg) = @_;
1102		1089
1103	$msg{msgid} = $id;	1090	$msg{msgid} = $id;
1104		1091
1105	$self->send ("ext " . to_json \%msg);	1092	$self->send ("ext " . cf::to_json \%msg);
1106	}	1093	}
		1094
		1095	package cf;
1107		1096
1108	=back	1097	=back
1109		1098
1110		1099
1111	=head3 cf::map	1100	=head3 cf::map
…		…
1117	package cf::map;	1106	package cf::map;
1118		1107
1119	use Fcntl;	1108	use Fcntl;
1120	use Coro::AIO;	1109	use Coro::AIO;
1121		1110
		1111	use overload
		1112	'""' => \&as_string;
		1113
1122	our $MAX_RESET = 3600;	1114	our $MAX_RESET = 3600;
1123	our $DEFAULT_RESET = 3000;	1115	our $DEFAULT_RESET = 3000;
1124		1116
1125	sub generate_random_map {	1117	sub generate_random_map {
1126	my ($path, $rmp) = @_;	1118	my ($self, $rmp) = @_;
1127		1119
1128	# mit "rum" bekleckern, nicht	1120	# mit "rum" bekleckern, nicht
1129	cf::map::_create_random_map	1121	$self->_create_random_map (
1130	$path,
1131	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},	1122	$rmp->{wallstyle}, $rmp->{wall_name}, $rmp->{floorstyle}, $rmp->{monsterstyle},
1132	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},	1123	$rmp->{treasurestyle}, $rmp->{layoutstyle}, $rmp->{doorstyle}, $rmp->{decorstyle},
1133	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},	1124	$rmp->{origin_map}, $rmp->{final_map}, $rmp->{exitstyle}, $rmp->{this_map},
1134	$rmp->{exit_on_final_map},	1125	$rmp->{exit_on_final_map},
1135	$rmp->{xsize}, $rmp->{ysize},	1126	$rmp->{xsize}, $rmp->{ysize},
1136	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},	1127	$rmp->{expand2x}, $rmp->{layoutoptions1}, $rmp->{layoutoptions2}, $rmp->{layoutoptions3},
1137	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},	1128	$rmp->{symmetry}, $rmp->{difficulty}, $rmp->{difficulty_given}, $rmp->{difficulty_increase},
1138	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},	1129	$rmp->{dungeon_level}, $rmp->{dungeon_depth}, $rmp->{decoroptions}, $rmp->{orientation},
1139	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},	1130	$rmp->{origin_y}, $rmp->{origin_x}, $rmp->{random_seed}, $rmp->{total_map_hp},
1140	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},	1131	$rmp->{map_layout_style}, $rmp->{treasureoptions}, $rmp->{symmetry_used},
1141	(cf::region::find $rmp->{region})	1132	(cf::region::find $rmp->{region}), $rmp->{custom}
		1133	)
		1134	}
		1135
		1136	sub register {
		1137	my (undef, $regex) = @_;
		1138	my $pkg = caller;
		1139
		1140	no strict;
		1141	push @{"$pkg\::ISA"}, __PACKAGE__;
		1142
		1143	$EXT_MAP{$pkg} = qr<$regex>;
		1144	}
		1145
		1146	# also paths starting with '/'
		1147	$EXT_MAP{"cf::map"} = qr{^(?=/)};
		1148
		1149	sub normalise {
		1150	my ($path, $base) = @_;
		1151
		1152	# map plan:
		1153	#
		1154	# /! non-realised random map exit (special hack!)
		1155	# {... are special paths that are not being touched
		1156	# ?xxx/... are special absolute paths
		1157	# ?random/... random maps
		1158	# /... normal maps
		1159	# ~user/... per-player map of a specific user
		1160
		1161	$path =~ s/$PATH_SEP/\//go;
		1162
		1163	# treat it as relative path if it starts with
		1164	# something that looks reasonable
		1165	if ($path =~ m{^(?:\./\|\.\./\|\w)}) {
		1166	$base or Carp::carp "normalise called with relative path and no base: '$path'";
		1167
		1168	$base =~ s{[^/]+/?$}{};
		1169	$path = "$base/$path";
		1170	}
		1171
		1172	for ($path) {
		1173	redo if s{//}{/};
		1174	redo if s{/\.?/}{/};
		1175	redo if s{/[^/]+/\.\./}{/};
		1176	}
		1177
		1178	$path
		1179	}
		1180
		1181	sub new_from_path {
		1182	my (undef, $path, $base) = @_;
		1183
		1184	return $path if UNIVERSAL::isa $path, "cf::map"; # already a map object
		1185
		1186	$path = normalise $path, $base;
		1187
		1188	for my $pkg (keys %EXT_MAP) {
		1189	if ($path =~ $EXT_MAP{$pkg}) {
		1190	my $self = bless cf::map::new, $pkg;
		1191	$self->{path} = $path; $self->path ($path);
		1192	$self->init; # pass $1 etc.
		1193	return $self;
		1194	}
		1195	}
		1196
		1197	Carp::carp "unable to resolve path '$path'.";
		1198	()
		1199	}
		1200
		1201	sub init {
		1202	my ($self) = @_;
		1203
		1204	$self
		1205	}
		1206
		1207	sub as_string {
		1208	my ($self) = @_;
		1209
		1210	"$self->{path}"
		1211	}
		1212
		1213	# the displayed name, this is a one way mapping
		1214	sub visible_name {
		1215	&as_string
		1216	}
		1217
		1218	# the original (read-only) location
		1219	sub load_path {
		1220	my ($self) = @_;
		1221
		1222	sprintf "%s/%s/%s", cf::datadir, cf::mapdir, $self->{path}
		1223	}
		1224
		1225	# the temporary/swap location
		1226	sub save_path {
		1227	my ($self) = @_;
		1228
		1229	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
		1230	sprintf "%s/%s/%s", cf::localdir, cf::tmpdir, $path
		1231	}
		1232
		1233	# the unique path, undef == no special unique path
		1234	sub uniq_path {
		1235	my ($self) = @_;
		1236
		1237	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/g;
		1238	sprintf "%s/%s/%s", cf::localdir, cf::uniquedir, $path
1142	}	1239	}
1143		1240
1144	# and all this just because we cannot iterate over	1241	# and all this just because we cannot iterate over
1145	# all maps in C++...	1242	# all maps in C++...
1146	sub change_all_map_light {	1243	sub change_all_map_light {
…		…
1148		1245
1149	$_->change_map_light ($change)	1246	$_->change_map_light ($change)
1150	for grep $_->outdoor, values %cf::MAP;	1247	for grep $_->outdoor, values %cf::MAP;
1151	}	1248	}
1152		1249
		1250	sub unlink_save {
		1251	my ($self) = @_;
		1252
		1253	utf8::encode (my $save = $self->save_path);
		1254	IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink $save;
		1255	IO::AIO::aioreq_pri 4; IO::AIO::aio_unlink "$save.pst";
		1256	}
		1257
1153	sub try_load_header($) {	1258	sub load_header_from($) {
1154	my ($path) = @_;	1259	my ($self, $path) = @_;
1155		1260
1156	utf8::encode $path;	1261	utf8::encode $path;
1157	aio_open $path, O_RDONLY, 0	1262	aio_open $path, O_RDONLY, 0
1158	or return;	1263	or return;
1159		1264
1160	my $map = cf::map::new	1265	$self->_load_header ($path)
1161	or return;	1266	or return;
1162		1267
1163	# for better error messages only, will be overwritten	1268	$self->{load_path} = $path;
1164	$map->path ($path);
1165		1269
1166	$map->load_header ($path)	1270	1
		1271	}
		1272
		1273	sub load_orig {
		1274	my ($self) = @_;
		1275
		1276	$self->load_header_from ($self->load_path)
		1277	}
		1278
		1279	sub load_temp {
		1280	my ($self) = @_;
		1281
		1282	$self->load_header_from ($self->save_path)
		1283	}
		1284
		1285	sub load_header {
		1286	my ($self) = @_;
		1287
		1288	if ($self->load_temp) {
		1289	$self->last_access ((delete $self->{last_access})
		1290	\|\| $cf::RUNTIME); #d#
		1291	# safety
		1292	$self->{instantiate_time} = $cf::RUNTIME
		1293	if $self->{instantiate_time} > $cf::RUNTIME;
		1294	} else {
		1295	$self->load_orig
1167	or return;	1296	or return;
1168		1297
1169	$map->{load_path} = $path;	1298	$self->{load_original} = 1;
		1299	$self->{instantiate_time} = $cf::RUNTIME;
		1300	$self->last_access ($cf::RUNTIME);
		1301	$self->instantiate;
		1302	}
1170		1303
1171	$map	1304	1
1172	}	1305	}
1173		1306
1174	sub find;	1307	sub find;
1175	sub find {	1308	sub find {
1176	my ($path, $origin) = @_;	1309	my ($path, $origin) = @_;
1177		1310
1178	#warn "find<$path,$origin>\n";#d#
1179
1180	$path = new cf::path $path, $origin && $origin->path;	1311	$path = normalise $path, $origin && $origin->path;
1181	my $key = $path->as_string;
1182		1312
1183	cf::lock_wait "map_find:$key";	1313	cf::lock_wait "map_find:$path";
1184		1314
1185	$cf::MAP{$key} \|\| do {	1315	$cf::MAP{$path} \|\| do {
1186	my $guard = cf::lock_acquire "map_find:$key";	1316	my $guard = cf::lock_acquire "map_find:$path";
1187		1317	my $map = new_from_path cf::map $path
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;	1318	or return;
1207		1319
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;	1320	$map->{last_save} = $cf::RUNTIME;
1220		1321
1221	Coro::cede;	1322	$map->load_header
		1323	or return;
1222		1324
1223	if ($map->should_reset) {	1325	if ($map->should_reset) {
1224	$map->reset;	1326	$map->reset;
1225	undef $guard;	1327	undef $guard;
1226	$map = find $path	1328	$map = find $path
1227	or return;	1329	or return;
1228	}	1330	}
1229		1331
1230	$cf::MAP{$key} = $map	1332	$cf::MAP{$path} = $map
1231	}	1333	}
1232	}	1334	}
1233		1335
1234	sub load {	1336	sub load {
1235	my ($self) = @_;	1337	my ($self) = @_;
1236		1338
1237	my $path = $self->{path};	1339	my $path = $self->{path};
1238	my $guard = cf::lock_acquire "map_load:" . $path->as_string;	1340	my $guard = cf::lock_acquire "map_load:$path";
1239		1341
1240	return if $self->in_memory != cf::MAP_SWAPPED;	1342	return if $self->in_memory != cf::MAP_SWAPPED;
1241		1343
1242	$self->in_memory (cf::MAP_LOADING);	1344	$self->in_memory (cf::MAP_LOADING);
1243		1345
1244	$self->alloc;	1346	$self->alloc;
1245	$self->load_objects ($self->{load_path}, 1)	1347	$self->_load_objects ($self->{load_path}, 1)
1246	or return;	1348	or return;
1247		1349
1248	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1350	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
1249	if delete $self->{load_original};	1351	if delete $self->{load_original};
1250		1352
1251	if (my $uniq = $path->uniq_path) {	1353	if (my $uniq = $self->uniq_path) {
1252	utf8::encode $uniq;	1354	utf8::encode $uniq;
1253	if (aio_open $uniq, O_RDONLY, 0) {	1355	if (aio_open $uniq, O_RDONLY, 0) {
1254	$self->clear_unique_items;	1356	$self->clear_unique_items;
1255	$self->load_objects ($uniq, 0);	1357	$self->_load_objects ($uniq, 0);
1256	}	1358	}
1257	}	1359	}
1258		1360
1259	Coro::cede;	1361	Coro::cede;
1260		1362
1261	# now do the right thing for maps	1363	# now do the right thing for maps
1262	$self->link_multipart_objects;	1364	$self->link_multipart_objects;
1263		1365
1264	if ($self->{path}->is_style_map) {	1366	unless ($self->{deny_activate}) {
1265	$self->{deny_save} = 1;	1367	$self->decay_objects;
1266	$self->{deny_reset} = 1;
1267	} else {
1268	$self->fix_auto_apply;	1368	$self->fix_auto_apply;
1269	$self->decay_objects;
1270	$self->update_buttons;	1369	$self->update_buttons;
		1370	Coro::cede;
1271	$self->set_darkness_map;	1371	$self->set_darkness_map;
1272	$self->difficulty ($self->estimate_difficulty)	1372	$self->difficulty ($self->estimate_difficulty)
1273	unless $self->difficulty;	1373	unless $self->difficulty;
		1374	Coro::cede;
1274	$self->activate;	1375	$self->activate;
1275	}	1376	}
1276		1377
1277	Coro::cede;
1278
1279	$self->in_memory (cf::MAP_IN_MEMORY);	1378	$self->in_memory (cf::MAP_IN_MEMORY);
		1379	}
		1380
		1381	sub customise_for {
		1382	my ($self, $ob) = @_;
		1383
		1384	return find "~" . $ob->name . "/" . $self->{path}
		1385	if $self->per_player;
		1386
		1387	$self
		1388	}
		1389
		1390	# find and load all maps in the 3x3 area around a map
		1391	sub load_diag {
		1392	my ($map) = @_;
		1393
		1394	my @diag; # diagonal neighbours
		1395
		1396	for (0 .. 3) {
		1397	my $neigh = $map->tile_path ($_)
		1398	or next;
		1399	$neigh = find $neigh, $map
		1400	or next;
		1401	$neigh->load;
		1402
		1403	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],
		1404	[$neigh->tile_path (($_ + 1) % 4), $neigh];
		1405	}
		1406
		1407	for (@diag) {
		1408	my $neigh = find @$_
		1409	or next;
		1410	$neigh->load;
		1411	}
1280	}	1412	}
1281		1413
1282	sub find_sync {	1414	sub find_sync {
1283	my ($path, $origin) = @_;	1415	my ($path, $origin) = @_;
1284		1416
1285	cf::sync_job { cf::map::find $path, $origin }	1417	cf::sync_job { find $path, $origin }
1286	}	1418	}
1287		1419
1288	sub do_load_sync {	1420	sub do_load_sync {
1289	my ($map) = @_;	1421	my ($map) = @_;
1290		1422
1291	cf::sync_job { $map->load };	1423	cf::sync_job { $map->load };
1292	}	1424	}
1293		1425
		1426	our %MAP_PREFETCH;
		1427	our $MAP_PREFETCHER = Coro::async {
		1428	while () {
		1429	for my $path (keys %MAP_PREFETCH) {
		1430	my $map = find $path
		1431	or next;
		1432	$map->load;
		1433
		1434	delete $MAP_PREFETCH{$path};
		1435	}
		1436	Coro::schedule;
		1437	}
		1438	};
		1439
		1440	sub find_async {
		1441	my ($path, $origin) = @_;
		1442
		1443	$path = normalise $path, $origin && $origin->{path};
		1444
		1445	if (my $map = $cf::MAP{$path}) {
		1446	return $map if $map->in_memory == cf::MAP_IN_MEMORY;
		1447	}
		1448
		1449	$MAP_PREFETCH{$path} = 0;
		1450	$MAP_PREFETCHER->ready;
		1451
		1452	()
		1453	}
		1454
1294	sub save {	1455	sub save {
1295	my ($self) = @_;	1456	my ($self) = @_;
1296		1457
1297	my $lock = cf::lock_acquire "map_data:" . $self->path;	1458	my $lock = cf::lock_acquire "map_data:" . $self->path;
1298		1459
1299	$self->{last_save} = $cf::RUNTIME;	1460	$self->{last_save} = $cf::RUNTIME;
1300		1461
1301	return unless $self->dirty;	1462	return unless $self->dirty;
1302		1463
1303	my $save = $self->{path}->save_path; utf8::encode $save;	1464	my $save = $self->save_path; utf8::encode $save;
1304	my $uniq = $self->{path}->uniq_path; utf8::encode $uniq;	1465	my $uniq = $self->uniq_path; utf8::encode $uniq;
1305		1466
1306	$self->{load_path} = $save;	1467	$self->{load_path} = $save;
1307		1468
1308	return if $self->{deny_save};	1469	return if $self->{deny_save};
1309		1470
1310	local $self->{last_access} = $self->last_access;#d#	1471	local $self->{last_access} = $self->last_access;#d#
1311		1472
		1473	cf::async {
		1474	$_->contr->save for $self->players;
		1475	};
		1476
1312	if ($uniq) {	1477	if ($uniq) {
1313	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);	1478	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS);
1314	$self->save_objects ($uniq, cf::IO_UNIQUES);	1479	$self->_save_objects ($uniq, cf::IO_UNIQUES);
1315	} else {	1480	} else {
1316	$self->save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);	1481	$self->_save_objects ($save, cf::IO_HEADER \| cf::IO_OBJECTS \| cf::IO_UNIQUES);
1317	}	1482	}
1318	}	1483	}
1319		1484
1320	sub swap_out {	1485	sub swap_out {
1321	my ($self) = @_;	1486	my ($self) = @_;
…		…
1335		1500
1336	sub reset_at {	1501	sub reset_at {
1337	my ($self) = @_;	1502	my ($self) = @_;
1338		1503
1339	# TODO: safety, remove and allow resettable per-player maps	1504	# TODO: safety, remove and allow resettable per-player maps
1340	return 1e99 if $self->{path}{user_rel};	1505	return 1e99 if $self->isa ("ext::map_per_player");#d#
1341	return 1e99 if $self->{deny_reset};	1506	return 1e99 if $self->{deny_reset};
1342		1507
1343	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;	1508	my $time = $self->fixed_resettime ? $self->{instantiate_time} : $self->last_access;
1344	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;	1509	my $to = List::Util::min $MAX_RESET, $self->reset_timeout \|\| $DEFAULT_RESET;
1345		1510
…		…
1350	my ($self) = @_;	1515	my ($self) = @_;
1351		1516
1352	$self->reset_at <= $cf::RUNTIME	1517	$self->reset_at <= $cf::RUNTIME
1353	}	1518	}
1354		1519
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 {	1520	sub rename {
1364	my ($self, $new_path) = @_;	1521	my ($self, $new_path) = @_;
1365		1522
		1523	normalise $new_path;
		1524
1366	$self->unlink_save;	1525	$self->unlink_save;
1367		1526
1368	delete $cf::MAP{$self->path};	1527	delete $cf::MAP{$self->path};
1369	$self->{path} = new cf::path $new_path;	1528	$self->{path} = $new_path; $self->path ($self->{path});
1370	$self->path ($self->{path}->as_string);
1371	$cf::MAP{$self->path} = $self;	1529	$cf::MAP{$self->path} = $self;
1372		1530
1373	$self->save;	1531	$self->save;
1374	}	1532	}
1375		1533
1376	sub reset {	1534	sub reset {
1377	my ($self) = @_;	1535	my ($self) = @_;
1378		1536
1379	my $lock = cf::lock_acquire "map_data:" . $self->path;	1537	my $lock = cf::lock_acquire "map_data:$self->{path}";
1380		1538
1381	return if $self->players;	1539	return if $self->players;
1382	return if $self->{path}{user_rel};#d#	1540	return if $self->isa ("ext::map_per_player");#d#
1383		1541
1384	warn "resetting map ", $self->path;#d#	1542	warn "resetting map ", $self->path;#d#
1385		1543
1386	delete $cf::MAP{$self->path};	1544	delete $cf::MAP{$self->path};
		1545
		1546	$self->in_memory (cf::MAP_SWAPPED);
		1547	$self->clear;
1387		1548
1388	$_->clear_links_to ($self) for values %cf::MAP;	1549	$_->clear_links_to ($self) for values %cf::MAP;
1389		1550
1390	$self->unlink_save;	1551	$self->unlink_save;
1391	$self->destroy;	1552	$self->destroy;
…		…
1400	$self->reset_timeout (1);	1561	$self->reset_timeout (1);
1401	$self->rename ("{nuke}/" . ($nuke_counter++));	1562	$self->rename ("{nuke}/" . ($nuke_counter++));
1402	$self->reset; # polite request, might not happen	1563	$self->reset; # polite request, might not happen
1403	}	1564	}
1404		1565
1405	sub customise_for {	1566	=item cf::map::unique_maps
1406	my ($map, $ob) = @_;
1407		1567
1408	if ($map->per_player) {	1568	Returns an arrayref of paths of all shared maps that have
1409	return cf::map::find "~" . $ob->name . "/" . $map->{path}{path};	1569	instantiated unique items. May block.
1410	}
1411		1570
1412	$map	1571	=cut
1413	}
1414		1572
1415	sub emergency_save {	1573	sub unique_maps() {
1416	my $freeze_guard = cf::freeze_mainloop;	1574	my $files = aio_readdir cf::localdir . "/" . cf::uniquedir
		1575	or return;
1417		1576
1418	warn "enter emergency map save\n";	1577	my @paths;
1419		1578
1420	cf::sync_job {	1579	for (@$files) {
1421	warn "begin emergency map save\n";	1580	utf8::decode $_;
1422	$_->save for values %cf::MAP;	1581	next if /\.pst$/;
		1582	next unless /^$PATH_SEP/o;
		1583
		1584	s/\.map$//;
		1585	push @paths, $_;
1423	};	1586	}
1424		1587
1425	warn "end emergency map save\n";	1588	\@paths
1426	}	1589	}
1427		1590
1428	package cf;	1591	package cf;
1429		1592
1430	=back	1593	=back
1431		1594
		1595	=head3 cf::object
		1596
		1597	=cut
		1598
		1599	package cf::object;
		1600
		1601	=over 4
		1602
		1603	=item $ob->inv_recursive
		1604
		1605	Returns the inventory of the object _and_ their inventories, recursively.
		1606
		1607	=cut
		1608
		1609	sub inv_recursive_;
		1610	sub inv_recursive_ {
		1611	map { $_, inv_recursive_ $_->inv } @_
		1612	}
		1613
		1614	sub inv_recursive {
		1615	inv_recursive_ inv $_[0]
		1616	}
		1617
		1618	package cf;
		1619
		1620	=back
1432		1621
1433	=head3 cf::object::player	1622	=head3 cf::object::player
1434		1623
1435	=over 4	1624	=over 4
1436		1625
…		…
1476		1665
1477	=item $player_object->enter_link	1666	=item $player_object->enter_link
1478		1667
1479	Freezes the player and moves him/her to a special map (C<{link}>).	1668	Freezes the player and moves him/her to a special map (C<{link}>).
1480		1669
1481	The player should be reaosnably safe there for short amounts of time. You	1670	The player should be reasonably safe there for short amounts of time. You
1482	I<MUST> call C<leave_link> as soon as possible, though.	1671	I<MUST> call C<leave_link> as soon as possible, though.
1483		1672
		1673	Will never block.
		1674
1484	=item $player_object->leave_link ($map, $x, $y)	1675	=item $player_object->leave_link ($map, $x, $y)
1485		1676
1486	Moves the player out of the specila link map onto the given map. If the	1677	Moves the player out of the special C<{link}> map onto the specified
1487	map is not valid (or omitted), the player will be moved back to the	1678	map. If the map is not valid (or omitted), the player will be moved back
1488	location he/she was before the call to C<enter_link>, or, if that fails,	1679	to the location he/she was before the call to C<enter_link>, or, if that
1489	to the emergency map position.	1680	fails, to the emergency map position.
1490		1681
1491	Might block.	1682	Might block.
1492		1683
1493	=cut	1684	=cut
		1685
		1686	sub link_map {
		1687	unless ($LINK_MAP) {
		1688	$LINK_MAP = cf::map::find "{link}"
		1689	or do { warn "FATAL: unable to provide {link} map, exiting."; exit 1 };
		1690	$LINK_MAP->load;
		1691	}
		1692
		1693	$LINK_MAP
		1694	}
1494		1695
1495	sub cf::object::player::enter_link {	1696	sub cf::object::player::enter_link {
1496	my ($self) = @_;	1697	my ($self) = @_;
1497		1698
1498	$self->deactivate_recursive;	1699	$self->deactivate_recursive;
1499		1700
1500	return if $self->map == $LINK_MAP;	1701	return if UNIVERSAL::isa $self->map, "ext::map_link";
1501		1702
1502	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]	1703	$self->{_link_pos} \|\|= [$self->map->{path}, $self->x, $self->y]
1503	if $self->map;	1704	if $self->map;
1504		1705
1505	$self->enter_map ($LINK_MAP, 20, 20);	1706	$self->enter_map ($LINK_MAP \|\| link_map, 20, 20);
1506	}	1707	}
1507		1708
1508	sub cf::object::player::leave_link {	1709	sub cf::object::player::leave_link {
1509	my ($self, $map, $x, $y) = @_;	1710	my ($self, $map, $x, $y) = @_;
1510		1711
…		…
1528	# use -1 or undef as default coordinates, not 0, 0	1729	# use -1 or undef as default coordinates, not 0, 0
1529	($x, $y) = ($map->enter_x, $map->enter_y)	1730	($x, $y) = ($map->enter_x, $map->enter_y)
1530	if $x <=0 && $y <= 0;	1731	if $x <=0 && $y <= 0;
1531		1732
1532	$map->load;	1733	$map->load;
		1734	$map->load_diag;
1533		1735
		1736	return unless $self->contr->active;
1534	$self->activate_recursive;	1737	$self->activate_recursive;
1535	$self->enter_map ($map, $x, $y);	1738	$self->enter_map ($map, $x, $y);
1536	}	1739	}
1537		1740
1538	cf::player->attach (	1741	cf::player->attach (
…		…
1550	my ($pl) = @_;	1753	my ($pl) = @_;
1551		1754
1552	# try to abort aborted map switching on player login :)	1755	# try to abort aborted map switching on player login :)
1553	# should happen only on crashes	1756	# should happen only on crashes
1554	if ($pl->ob->{_link_pos}) {	1757	if ($pl->ob->{_link_pos}) {
1555
1556	$pl->ob->enter_link;	1758	$pl->ob->enter_link;
1557	(async {	1759	(async {
1558	# we need this sleep as the login has a concurrent enter_exit running	1760	# 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	1761	# and this sleep increases chances of the player not ending up in scorn
1560	$pl->ob->reply (undef,	1762	$pl->ob->reply (undef,
…		…
1576	my ($self, $path, $x, $y) = @_;	1778	my ($self, $path, $x, $y) = @_;
1577		1779
1578	$self->enter_link;	1780	$self->enter_link;
1579		1781
1580	(async {	1782	(async {
1581	$path = new cf::path $path;
1582
1583	my $map = cf::map::find $path->as_string;	1783	my $map = cf::map::find $path;
1584	$map = $map->customise_for ($self) if $map;	1784	$map = $map->customise_for ($self) if $map;
1585		1785
1586	# warn "entering ", $map->path, " at ($x, $y)\n"	1786	# warn "entering ", $map->path, " at ($x, $y)\n"
1587	# if $map;	1787	# if $map;
1588		1788
1589	$map or $self->message ("The exit is closed", cf::NDI_UNIQUE \| cf::NDI_RED);	1789	$map or $self->message ("The exit to '" . ($path->visible_name) . "' is closed", cf::NDI_UNIQUE \| cf::NDI_RED);
1590		1790
1591	$self->leave_link ($map, $x, $y);	1791	$self->leave_link ($map, $x, $y);
1592	})->prio (1);	1792	})->prio (1);
1593	}	1793	}
1594		1794
…		…
1653	$self->deactivate_recursive; # just to be sure	1853	$self->deactivate_recursive; # just to be sure
1654	unless (eval {	1854	unless (eval {
1655	prepare_random_map $exit	1855	prepare_random_map $exit
1656	if $exit->slaying eq "/!";	1856	if $exit->slaying eq "/!";
1657		1857
1658	my $path = new cf::path $exit->slaying, $exit->map && $exit->map->path;	1858	my $path = new_from_path cf::map $exit->slaying, $exit->map && $exit->map->path;
1659	$self->goto ($path, $exit->stats->hp, $exit->stats->sp);	1859	$self->goto ($path, $exit->stats->hp, $exit->stats->sp);
1660		1860
1661	1;	1861	1;
1662	}) {	1862	}) {
1663	$self->message ("Something went wrong deep within the crossfire server. "	1863	$self->message ("Something went wrong deep within the crossfire server. "
1664	. "I'll try to bring you back to the map you were before. "	1864	. "I'll try to bring you back to the map you were before. "
1665	. "Please report this to the dungeon master",	1865	. "Please report this to the dungeon master!",
1666	cf::NDI_UNIQUE \| cf::NDI_RED);	1866	cf::NDI_UNIQUE \| cf::NDI_RED);
1667		1867
1668	warn "ERROR in enter_exit: $@";	1868	warn "ERROR in enter_exit: $@";
1669	$self->leave_link;	1869	$self->leave_link;
1670	}	1870	}
…		…
2002	$cf::map::MAX_RESET = $CFG{map_max_reset} if exists $CFG{map_max_reset};	2202	$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};	2203	$cf::map::DEFAULT_RESET = $CFG{map_default_reset} if exists $CFG{map_default_reset};
2004		2204
2005	if (exists $CFG{mlockall}) {	2205	if (exists $CFG{mlockall}) {
2006	eval {	2206	eval {
2007	$CFG{mlockall} ? &mlockall : &munlockall	2207	$CFG{mlockall} ? eval "mlockall()" : eval "munlockall()"
2008	and die "WARNING: m(un)lockall failed: $!\n";	2208	and die "WARNING: m(un)lockall failed: $!\n";
2009	};	2209	};
2010	warn $@ if $@;	2210	warn $@ if $@;
2011	}	2211	}
2012	}	2212	}
…		…
2023	load_extensions;	2223	load_extensions;
2024	Event::loop;	2224	Event::loop;
2025	}	2225	}
2026		2226
2027	#############################################################################	2227	#############################################################################
2028	# initialisation	2228	# initialisation and cleanup
		2229
		2230	# install some emergency cleanup handlers
		2231	BEGIN {
		2232	for my $signal (qw(INT HUP TERM)) {
		2233	Event->signal (
		2234	data => WF_AUTOCANCEL,
		2235	signal => $signal,
		2236	cb => sub {
		2237	cf::cleanup "SIG$signal";
		2238	},
		2239	);
		2240	}
		2241	}
		2242
		2243	sub emergency_save() {
		2244	my $freeze_guard = cf::freeze_mainloop;
		2245
		2246	warn "enter emergency perl save\n";
		2247
		2248	cf::sync_job {
		2249	# use a peculiar iteration method to avoid tripping on perl
		2250	# refcount bugs in for. also avoids problems with players
		2251	# and maps saved/destroyed asynchronously.
		2252	warn "begin emergency player save\n";
		2253	for my $login (keys %cf::PLAYER) {
		2254	my $pl = $cf::PLAYER{$login} or next;
		2255	$pl->valid or next;
		2256	$pl->save;
		2257	}
		2258	warn "end emergency player save\n";
		2259
		2260	warn "begin emergency map save\n";
		2261	for my $path (keys %cf::MAP) {
		2262	my $map = $cf::MAP{$path} or next;
		2263	$map->valid or next;
		2264	$map->save;
		2265	}
		2266	warn "end emergency map save\n";
		2267	};
		2268
		2269	warn "leave emergency perl save\n";
		2270	}
2029		2271
2030	sub reload() {	2272	sub reload() {
2031	# can/must only be called in main	2273	# can/must only be called in main
2032	if ($Coro::current != $Coro::main) {	2274	if ($Coro::current != $Coro::main) {
2033	warn "can only reload from main coroutine\n";	2275	warn "can only reload from main coroutine\n";
2034	return;	2276	return;
2035	}	2277	}
2036		2278
2037	warn "reloading...";	2279	warn "reloading...";
2038		2280
		2281	warn "freezing server";
2039	my $guard = freeze_mainloop;	2282	my $guard = freeze_mainloop;
2040	cf::emergency_save;	2283	cf::emergency_save;
2041		2284
		2285	warn "sync database to disk";
		2286	cf::db_sync;
		2287	IO::AIO::flush;
		2288
2042	eval {	2289	eval {
2043	# if anything goes wrong in here, we should simply crash as we already saved	2290	# if anything goes wrong in here, we should simply crash as we already saved
2044		2291
2045	# cancel all watchers	2292	warn "cancel all watchers";
2046	for (Event::all_watchers) {	2293	for (Event::all_watchers) {
2047	$_->cancel if $_->data & WF_AUTOCANCEL;	2294	$_->cancel if $_->data & WF_AUTOCANCEL;
2048	}	2295	}
2049		2296
2050	# cancel all extension coros	2297	warn "cancel all extension coros";
2051	$_->cancel for values %EXT_CORO;	2298	$_->cancel for values %EXT_CORO;
2052	%EXT_CORO = ();	2299	%EXT_CORO = ();
2053		2300
		2301	warn "remove commands";
		2302	%COMMAND = ();
		2303
		2304	warn "remove ext commands";
		2305	%EXTCMD = ();
		2306
2054	# unload all extensions	2307	warn "unload/nuke all extensions";
2055	for (@exts) {	2308	for my $pkg (@EXTS) {
2056	warn "unloading <$_>";	2309	warn "... unloading $pkg";
2057	unload_extension $_;	2310
		2311	if (my $cb = $pkg->can ("unload")) {
		2312	eval {
		2313	$cb->($pkg);
		2314	1
		2315	} or warn "$pkg unloaded, but with errors: $@";
2058	}	2316	}
2059		2317
		2318	warn "... nuking $pkg";
		2319	Symbol::delete_package $pkg;
		2320	}
		2321
2060	# unload all modules loaded from $LIBDIR	2322	warn "unload all perl modules loaded from $LIBDIR";
2061	while (my ($k, $v) = each %INC) {	2323	while (my ($k, $v) = each %INC) {
2062	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;	2324	next unless $v =~ /^\Q$LIBDIR\E\/.*\.pm$/;
2063		2325
2064	warn "removing <$k>";	2326	warn "removing <$k>";
2065	delete $INC{$k};	2327	delete $INC{$k};
…		…
2072	}	2334	}
2073		2335
2074	Symbol::delete_package $k;	2336	Symbol::delete_package $k;
2075	}	2337	}
2076		2338
2077	# sync database to disk
2078	cf::db_sync;
2079	IO::AIO::flush;
2080
2081	# get rid of safe::, as good as possible	2339	warn "get rid of safe::, as good as possible";
2082	Symbol::delete_package "safe::$_"	2340	Symbol::delete_package "safe::$_"
2083	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	2341	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
2084		2342
2085	# remove register_script_function callbacks
2086	# TODO
2087
2088	# unload cf.pm "a bit"	2343	warn "unload cf.pm \"a bit\"";
2089	delete $INC{"cf.pm"};	2344	delete $INC{"cf.pm"};
2090		2345
2091	# don't, removes xs symbols, too,	2346	# don't, removes xs symbols, too,
2092	# and global variables created in xs	2347	# and global variables created in xs
2093	#Symbol::delete_package __PACKAGE__;	2348	#Symbol::delete_package __PACKAGE__;
2094		2349
2095	# reload cf.pm
2096	warn "reloading cf.pm";	2350	warn "reloading cf.pm";
2097	require cf;	2351	require cf;
2098	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	2352	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
2099		2353
2100	# load config and database again	2354	warn "load config and database again";
2101	cf::cfg_load;	2355	cf::cfg_load;
2102	cf::db_load;	2356	cf::db_load;
2103		2357
2104	# load extensions
2105	warn "load extensions";	2358	warn "load extensions";
2106	cf::load_extensions;	2359	cf::load_extensions;
2107		2360
2108	# reattach attachments to objects	2361	warn "reattach attachments to objects/players";
2109	warn "reattach";
2110	_global_reattach;	2362	_global_reattach;
		2363	warn "reattach attachments to maps";
		2364	reattach $_ for values %MAP;
2111	};	2365	};
2112		2366
2113	if ($@) {	2367	if ($@) {
2114	warn $@;	2368	warn $@;
2115	warn "error while reloading, exiting.";	2369	warn "error while reloading, exiting.";
2116	exit 1;	2370	exit 1;
2117	}	2371	}
2118		2372
2119	warn "reloaded successfully";	2373	warn "reloaded";
2120	};	2374	};
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
2165	register "<global>", __PACKAGE__;
2166		2375
2167	register_command "reload" => sub {	2376	register_command "reload" => sub {
2168	my ($who, $arg) = @_;	2377	my ($who, $arg) = @_;
2169		2378
2170	if ($who->flag (FLAG_WIZ)) {	2379	if ($who->flag (FLAG_WIZ)) {
…		…
2180	reentrant => 0,	2389	reentrant => 0,
2181	prio => 0,	2390	prio => 0,
2182	at => $NEXT_TICK \|\| $TICK,	2391	at => $NEXT_TICK \|\| $TICK,
2183	data => WF_AUTOCANCEL,	2392	data => WF_AUTOCANCEL,
2184	cb => sub {	2393	cb => sub {
		2394	$NOW = Event::time;
		2395
2185	cf::server_tick; # one server iteration	2396	cf::server_tick; # one server iteration
2186	$RUNTIME += $TICK;	2397	$RUNTIME += $TICK;
2187	$NEXT_TICK += $TICK;	2398	$NEXT_TICK += $TICK;
		2399
		2400	$WAIT_FOR_TICK->broadcast;
		2401	$WAIT_FOR_TICK_ONE->send if $WAIT_FOR_TICK_ONE->awaited;
2188		2402
2189	# if we are delayed by four ticks or more, skip them all	2403	# if we are delayed by four ticks or more, skip them all
2190	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;	2404	$NEXT_TICK = Event::time if Event::time >= $NEXT_TICK + $TICK * 4;
2191		2405
2192	$TICK_WATCHER->at ($NEXT_TICK);	2406	$TICK_WATCHER->at ($NEXT_TICK);
…		…
2194	},	2408	},
2195	);	2409	);
2196		2410
2197	IO::AIO::max_poll_time $TICK * 0.2;	2411	IO::AIO::max_poll_time $TICK * 0.2;
2198		2412
2199	Event->io (	2413	$AIO_POLL_WATCHER = Event->io (
2200	fd => IO::AIO::poll_fileno,	2414	fd => IO::AIO::poll_fileno,
2201	poll => 'r',	2415	poll => 'r',
2202	prio => 5,	2416	prio => 5,
2203	data => WF_AUTOCANCEL,	2417	data => WF_AUTOCANCEL,
2204	cb => \&IO::AIO::poll_cb,	2418	cb => \&IO::AIO::poll_cb,
2205	);	2419	);
2206		2420
2207	Event->timer (	2421	$WRITE_RUNTIME_WATCHER = Event->timer (
2208	data => WF_AUTOCANCEL,	2422	data => WF_AUTOCANCEL,
2209	after => 0,	2423	after => 0,
2210	interval => 10,	2424	interval => 10,
2211	cb => sub {	2425	cb => sub {
2212	(Coro::unblock_sub {	2426	(Coro::unblock_sub {

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.140 by root, Fri Jan 5 20:04:02 2007 UTC vs. Revision 1.169 by root, Sun Jan 14 01:09:46 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.140 by root, Fri Jan 5 20:04:02 2007 UTC vs.
Revision 1.169 by root, Sun Jan 14 01:09:46 2007 UTC