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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.447 by root, Fri Sep 19 01:39:45 2008 UTC vs.
Revision 1.473 by root, Fri Jun 26 16:32:10 2009 UTC

…		…
21		21
22	package cf;	22	package cf;
23		23
24	use 5.10.0;	24	use 5.10.0;
25	use utf8;	25	use utf8;
26	use strict "vars", "subs";	26	use strict qw(vars subs);
27		27
28	use Symbol;	28	use Symbol;
29	use List::Util;	29	use List::Util;
30	use Socket;	30	use Socket;
31	use EV;	31	use EV;
32	use Opcode;	32	use Opcode;
33	use Safe;	33	use Safe;
34	use Safe::Hole;	34	use Safe::Hole;
35	use Storable ();	35	use Storable ();
36		36
		37	use Guard ();
37	use Coro ();	38	use Coro ();
38	use Coro::State;	39	use Coro::State;
39	use Coro::Handle;	40	use Coro::Handle;
40	use Coro::EV;	41	use Coro::EV;
41	use Coro::AnyEvent;	42	use Coro::AnyEvent;
42	use Coro::Timer;	43	use Coro::Timer;
43	use Coro::Signal;	44	use Coro::Signal;
44	use Coro::Semaphore;	45	use Coro::Semaphore;
		46	use Coro::SemaphoreSet;
45	use Coro::AnyEvent;	47	use Coro::AnyEvent;
46	use Coro::AIO;	48	use Coro::AIO;
47	use Coro::BDB 1.6;	49	use Coro::BDB 1.6;
48	use Coro::Storable;	50	use Coro::Storable;
49	use Coro::Util ();	51	use Coro::Util ();
…		…
63		65
64	# configure various modules to our taste	66	# configure various modules to our taste
65	#	67	#
66	$Storable::canonical = 1; # reduce rsync transfers	68	$Storable::canonical = 1; # reduce rsync transfers
67	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator	69	Coro::State::cctx_stacksize 256000; # 1-2MB stack, for deep recursions in maze generator
		70
		71	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
		72
		73	# make sure c-lzf reinitialises itself
		74	Compress::LZF::set_serializer "Storable", "Storable::net_mstore", "Storable::mretrieve";
68	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later	75	Compress::LZF::sfreeze_cr { }; # prime Compress::LZF so it does not use require later
69
70	$Coro::main->prio (Coro::PRIO_MAX); # run main coroutine ("the server") with very high priority
71		76
72	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload	77	sub WF_AUTOCANCEL () { 1 } # automatically cancel this watcher on reload
73		78
74	our %COMMAND = ();	79	our %COMMAND = ();
75	our %COMMAND_TIME = ();	80	our %COMMAND_TIME = ();
…		…
78	our %EXTCMD = ();	83	our %EXTCMD = ();
79	our %EXTICMD = ();	84	our %EXTICMD = ();
80	our %EXT_CORO = (); # coroutines bound to extensions	85	our %EXT_CORO = (); # coroutines bound to extensions
81	our %EXT_MAP = (); # pluggable maps	86	our %EXT_MAP = (); # pluggable maps
82		87
83	our $RELOAD; # number of reloads so far	88	our $RELOAD; # number of reloads so far, non-zero while in reload
84	our @EVENT;	89	our @EVENT;
85		90
86	our $CONFDIR = confdir;	91	our $CONFDIR = confdir;
87	our $DATADIR = datadir;	92	our $DATADIR = datadir;
88	our $LIBDIR = "$DATADIR/ext";	93	our $LIBDIR = "$DATADIR/ext";
…		…
100	our %RESOURCE;	105	our %RESOURCE;
101		106
102	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)	107	our $TICK = MAX_TIME * 1e-6; # this is a CONSTANT(!)
103	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written	108	our $NEXT_RUNTIME_WRITE; # when should the runtime file be written
104	our $NEXT_TICK;	109	our $NEXT_TICK;
105	our $USE_FSYNC = 1; # use fsync to write maps - default off	110	our $USE_FSYNC = 1; # use fsync to write maps - default on
106		111
107	our $BDB_DEADLOCK_WATCHER;	112	our $BDB_DEADLOCK_WATCHER;
108	our $BDB_CHECKPOINT_WATCHER;	113	our $BDB_CHECKPOINT_WATCHER;
109	our $BDB_TRICKLE_WATCHER;	114	our $BDB_TRICKLE_WATCHER;
110	our $DB_ENV;	115	our $DB_ENV;
111		116
		117	our @EXTRA_MODULES = qw(pod mapscript);
		118
112	our %CFG;	119	our %CFG;
113		120
114	our $UPTIME; $UPTIME \|\|= time;	121	our $UPTIME; $UPTIME \|\|= time;
115	our $RUNTIME;	122	our $RUNTIME;
116	our $NOW;	123	our $NOW;
…		…
124		131
125	our $LOAD; # a number between 0 (idle) and 1 (too many objects)	132	our $LOAD; # a number between 0 (idle) and 1 (too many objects)
126	our $LOADAVG; # same thing, but with alpha-smoothing	133	our $LOADAVG; # same thing, but with alpha-smoothing
127	our $JITTER; # average jitter	134	our $JITTER; # average jitter
128	our $TICK_START; # for load detecting purposes	135	our $TICK_START; # for load detecting purposes
		136
		137	our @POST_INIT;
		138
		139	our $REATTACH_ON_RELOAD; # ste to true to force object reattach on reload (slow)
129		140
130	binmode STDOUT;	141	binmode STDOUT;
131	binmode STDERR;	142	binmode STDERR;
132		143
133	# read virtual server time, if available	144	# read virtual server time, if available
134	unless ($RUNTIME \|\| !-e $RUNTIMEFILE) {	145	unless ($RUNTIME \|\| !-e $RUNTIMEFILE) {
135	open my $fh, "<", $RUNTIMEFILE	146	open my $fh, "<", $RUNTIMEFILE
136	or die "unable to read $RUNTIMEFILE file: $!";	147	or die "unable to read $RUNTIMEFILE file: $!";
137	$RUNTIME = <$fh> + 0.;	148	$RUNTIME = <$fh> + 0.;
138	}	149	}
		150
		151	eval "sub TICK() { $TICK } 1" or die;
139		152
140	mkdir $_	153	mkdir $_
141	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;	154	for $LOCALDIR, $TMPDIR, $UNIQUEDIR, $PLAYERDIR, $RANDOMDIR, $BDBDIR;
142		155
143	our $EMERGENCY_POSITION;	156	our $EMERGENCY_POSITION;
…		…
302	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max	315	our $json_coder = JSON::XS->new->utf8->max_size (1e6); # accept ~1mb max
303		316
304	sub encode_json($) { $json_coder->encode ($_[0]) }	317	sub encode_json($) { $json_coder->encode ($_[0]) }
305	sub decode_json($) { $json_coder->decode ($_[0]) }	318	sub decode_json($) { $json_coder->decode ($_[0]) }
306		319
		320	=item cf::post_init { BLOCK }
		321
		322	Execute the given codeblock, I<after> all extensions have been (re-)loaded,
		323	but I<before> the server starts ticking again.
		324
		325	The cdoeblock will have a single boolean argument to indicate whether this
		326	is a reload or not.
		327
		328	=cut
		329
		330	sub post_init(&) {
		331	push @POST_INIT, shift;
		332	}
		333
307	=item cf::lock_wait $string	334	=item cf::lock_wait $string
308		335
309	Wait until the given lock is available. See cf::lock_acquire.	336	Wait until the given lock is available. See cf::lock_acquire.
310		337
311	=item my $lock = cf::lock_acquire $string	338	=item my $lock = cf::lock_acquire $string
312		339
313	Wait until the given lock is available and then acquires it and returns	340	Wait until the given lock is available and then acquires it and returns
314	a Coro::guard object. If the guard object gets destroyed (goes out of scope,	341	a L<Guard> object. If the guard object gets destroyed (goes out of scope,
315	for example when the coroutine gets canceled), the lock is automatically	342	for example when the coroutine gets canceled), the lock is automatically
316	returned.	343	returned.
317		344
318	Locks are not recursive, locking from the same coro twice results in a	345	Locks are not recursive, locking from the same coro twice results in a
319	deadlocked coro.	346	deadlocked coro.
…		…
325		352
326	Return true if the lock is currently active, i.e. somebody has locked it.	353	Return true if the lock is currently active, i.e. somebody has locked it.
327		354
328	=cut	355	=cut
329		356
330	our %LOCK;	357	our $LOCKS = new Coro::SemaphoreSet;
331	our %LOCKER;#d#
332		358
333	sub lock_wait($) {	359	sub lock_wait($) {
334	my ($key) = @_;	360	$LOCKS->wait ($_[0]);
335
336	if ($LOCKER{$key} == $Coro::current) {#d#
337	Carp::cluck "lock_wait($key) for already-acquired lock";#d#
338	return;#d#
339	}#d#
340
341	# wait for lock, if any
342	while ($LOCK{$key}) {
343	push @{ $LOCK{$key} }, $Coro::current;
344	Coro::schedule;
345	}
346	}	361	}
347		362
348	sub lock_acquire($) {	363	sub lock_acquire($) {
349	my ($key) = @_;	364	$LOCKS->guard ($_[0])
350
351	# wait, to be sure we are not locked
352	lock_wait $key;
353
354	$LOCK{$key} = [];
355	$LOCKER{$key} = $Coro::current;#d#
356
357	Coro::guard {
358	delete $LOCKER{$key};#d#
359	# wake up all waiters, to be on the safe side
360	$_->ready for @{ delete $LOCK{$key} };
361	}
362	}	365	}
363		366
364	sub lock_active($) {	367	sub lock_active($) {
365	my ($key) = @_;	368	$LOCKS->count ($_[0]) < 1
366
367	! ! $LOCK{$key}
368	}	369	}
369		370
370	sub freeze_mainloop {	371	sub freeze_mainloop {
371	tick_inhibit_inc;	372	tick_inhibit_inc;
372		373
373	Coro::guard \&tick_inhibit_dec;	374	&Guard::guard (\&tick_inhibit_dec);
374	}	375	}
375		376
376	=item cf::periodic $interval, $cb	377	=item cf::periodic $interval, $cb
377		378
378	Like EV::periodic, but randomly selects a starting point so that the actions	379	Like EV::periodic, but randomly selects a starting point so that the actions
…		…
1150	$decname, length $$rdata, scalar @$objs;	1151	$decname, length $$rdata, scalar @$objs;
1151		1152
1152	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {	1153	if (my $fh = aio_open "$filename~", O_WRONLY \| O_CREAT, 0600) {
1153	aio_chmod $fh, SAVE_MODE;	1154	aio_chmod $fh, SAVE_MODE;
1154	aio_write $fh, 0, (length $$rdata), $$rdata, 0;	1155	aio_write $fh, 0, (length $$rdata), $$rdata, 0;
1155	aio_fsync $fh if $cf::USE_FSYNC;	1156	if ($cf::USE_FSYNC) {
		1157	aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE \| IO::AIO::SYNC_FILE_RANGE_WRITE \| IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
		1158	aio_fsync $fh;
		1159	}
1156	aio_close $fh;	1160	aio_close $fh;
1157		1161
1158	if (@$objs) {	1162	if (@$objs) {
1159	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {	1163	if (my $fh = aio_open "$filename.pst~", O_WRONLY \| O_CREAT, 0600) {
1160	aio_chmod $fh, SAVE_MODE;	1164	aio_chmod $fh, SAVE_MODE;
1161	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };	1165	my $data = Coro::Storable::nfreeze { version => 1, objs => $objs };
1162	aio_write $fh, 0, (length $data), $data, 0;	1166	aio_write $fh, 0, (length $data), $data, 0;
1163	aio_fsync $fh if $cf::USE_FSYNC;	1167	if ($cf::USE_FSYNC) {
		1168	aio_sync_file_range $fh, 0, 0, IO::AIO::SYNC_FILE_RANGE_WAIT_BEFORE \| IO::AIO::SYNC_FILE_RANGE_WRITE \| IO::AIO::SYNC_FILE_RANGE_WAIT_AFTER;
		1169	aio_fsync $fh;
		1170	}
1164	aio_close $fh;	1171	aio_close $fh;
1165	aio_rename "$filename.pst~", "$filename.pst";	1172	aio_rename "$filename.pst~", "$filename.pst";
1166	}	1173	}
1167	} else {	1174	} else {
1168	aio_unlink "$filename.pst";	1175	aio_unlink "$filename.pst";
1169	}	1176	}
1170		1177
1171	aio_rename "$filename~", $filename;	1178	aio_rename "$filename~", $filename;
		1179
		1180	$filename =~ s%/[^/]+$%%;
		1181	aio_pathsync $filename if $cf::USE_FSYNC;
1172	} else {	1182	} else {
1173	warn "FATAL: $filename~: $!\n";	1183	warn "unable to save objects: $filename~: $!\n";
1174	}	1184	}
1175	} else {	1185	} else {
1176	aio_unlink $filename;	1186	aio_unlink $filename;
1177	aio_unlink "$filename.pst";	1187	aio_unlink "$filename.pst";
1178	}	1188	}
…		…
1269	my ($name, $cb) = @_;	1279	my ($name, $cb) = @_;
1270		1280
1271	$EXTICMD{$name} = $cb;	1281	$EXTICMD{$name} = $cb;
1272	}	1282	}
1273		1283
		1284	use File::Glob ();
		1285
1274	cf::player->attach (	1286	cf::player->attach (
1275	on_command => sub {	1287	on_command => sub {
1276	my ($pl, $name, $params) = @_;	1288	my ($pl, $name, $params) = @_;
1277		1289
1278	my $cb = $COMMAND{$name}	1290	my $cb = $COMMAND{$name}
…		…
1309	}	1321	}
1310		1322
1311	cf::override;	1323	cf::override;
1312	},	1324	},
1313	);	1325	);
		1326
		1327	# "readahead" all extensions
		1328	sub cache_extensions {
		1329	my $grp = IO::AIO::aio_group;
		1330
		1331	add $grp IO::AIO::aio_readdirx $LIBDIR, IO::AIO::READDIR_STAT_ORDER, sub {
		1332	for (grep /\.ext$/, @{$_[0]}) {
		1333	add $grp IO::AIO::aio_load "$LIBDIR/$_", my $data;
		1334	}
		1335	};
		1336
		1337	$grp
		1338	}
1314		1339
1315	sub load_extensions {	1340	sub load_extensions {
1316	cf::sync_job {	1341	cf::sync_job {
1317	my %todo;	1342	my %todo;
1318		1343
…		…
1441		1466
1442	sub exists($) {	1467	sub exists($) {
1443	my ($login) = @_;	1468	my ($login) = @_;
1444		1469
1445	$cf::PLAYER{$login}	1470	$cf::PLAYER{$login}
1446	or cf::sync_job { !aio_stat path $login }	1471	or !aio_stat path $login
1447	}	1472	}
1448		1473
1449	sub find($) {	1474	sub find($) {
1450	return $cf::PLAYER{$_[0]} \|\| do {	1475	return $cf::PLAYER{$_[0]} \|\| do {
1451	my $login = $_[0];	1476	my $login = $_[0];
…		…
1847		1872
1848	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;	1873	(my $path = $_[0]{path}) =~ s/\//$PATH_SEP/go;
1849	"$UNIQUEDIR/$path"	1874	"$UNIQUEDIR/$path"
1850	}	1875	}
1851		1876
1852	# and all this just because we cannot iterate over
1853	# all maps in C++...
1854	sub change_all_map_light {
1855	my ($change) = @_;
1856
1857	$_->change_map_light ($change)
1858	for grep $_->outdoor, values %cf::MAP;
1859	}
1860
1861	sub decay_objects {	1877	sub decay_objects {
1862	my ($self) = @_;	1878	my ($self) = @_;
1863		1879
1864	return if $self->{deny_reset};	1880	return if $self->{deny_reset};
1865		1881
…		…
1947	sub find {	1963	sub find {
1948	my ($path, $origin) = @_;	1964	my ($path, $origin) = @_;
1949		1965
1950	$path = normalise $path, $origin && $origin->path;	1966	$path = normalise $path, $origin && $origin->path;
1951		1967
1952	cf::lock_wait "map_data:$path";#d#remove	1968	my $guard1 = cf::lock_acquire "map_data:$path";#d#remove
1953	cf::lock_wait "map_find:$path";	1969	my $guard2 = cf::lock_acquire "map_find:$path";
1954		1970
1955	$cf::MAP{$path} \|\| do {	1971	$cf::MAP{$path} \|\| do {
1956	my $guard1 = cf::lock_acquire "map_data:$path"; # just for the fun of it
1957	my $guard2 = cf::lock_acquire "map_find:$path";
1958
1959	my $map = new_from_path cf::map $path	1972	my $map = new_from_path cf::map $path
1960	or return;	1973	or return;
1961		1974
1962	$map->{last_save} = $cf::RUNTIME;	1975	$map->{last_save} = $cf::RUNTIME;
1963		1976
…		…
2030		2043
2031	unless ($self->{deny_activate}) {	2044	unless ($self->{deny_activate}) {
2032	$self->decay_objects;	2045	$self->decay_objects;
2033	$self->fix_auto_apply;	2046	$self->fix_auto_apply;
2034	$self->update_buttons;	2047	$self->update_buttons;
2035	cf::cede_to_tick;
2036	$self->set_darkness_map;
2037	cf::cede_to_tick;	2048	cf::cede_to_tick;
2038	$self->activate;	2049	$self->activate;
2039	}	2050	}
2040		2051
2041	$self->{last_save} = $cf::RUNTIME;	2052	$self->{last_save} = $cf::RUNTIME;
…		…
2383		2394
2384	our $SAY_CHANNEL = {	2395	our $SAY_CHANNEL = {
2385	id => "say",	2396	id => "say",
2386	title => "Map",	2397	title => "Map",
2387	reply => "say ",	2398	reply => "say ",
2388	tooltip => "Things said to and replied from npcs near you and other players on the same map only.",	2399	tooltip => "Things said to and replied from NPCs near you and other players on the same map only.",
2389	};	2400	};
2390		2401
2391	our $CHAT_CHANNEL = {	2402	our $CHAT_CHANNEL = {
2392	id => "chat",	2403	id => "chat",
2393	title => "Chat",	2404	title => "Chat",
…		…
2768	id => "infobox",	2779	id => "infobox",
2769	title => "Body Parts",	2780	title => "Body Parts",
2770	reply => undef,	2781	reply => undef,
2771	tooltip => "Shows which body parts you posess and are available",	2782	tooltip => "Shows which body parts you posess and are available",
2772	},	2783	},
		2784	"c/statistics" => {
		2785	id => "infobox",
		2786	title => "Statistics",
		2787	reply => undef,
		2788	tooltip => "Shows your primary statistics",
		2789	},
		2790	"c/skills" => {
		2791	id => "infobox",
		2792	title => "Skills",
		2793	reply => undef,
		2794	tooltip => "Shows your experience per skill and item power",
		2795	},
		2796	"c/shopitems" => {
		2797	id => "infobox",
		2798	title => "Shop Items",
		2799	reply => undef,
		2800	tooltip => "Shows the items currently for sale in this shop",
		2801	},
		2802	"c/resistances" => {
		2803	id => "infobox",
		2804	title => "Resistances",
		2805	reply => undef,
		2806	tooltip => "Shows your resistances",
		2807	},
		2808	"c/pets" => {
		2809	id => "infobox",
		2810	title => "Pets",
		2811	reply => undef,
		2812	tooltip => "Shows information abotu your pets/a specific pet",
		2813	},
		2814	"c/perceiveself" => {
		2815	id => "infobox",
		2816	title => "Perceive Self",
		2817	reply => undef,
		2818	tooltip => "You gained detailed knowledge about yourself",
		2819	},
2773	"c/uptime" => {	2820	"c/uptime" => {
2774	id => "infobox",	2821	id => "infobox",
2775	title => "Uptime",	2822	title => "Uptime",
2776	reply => undef,	2823	reply => undef,
2777	tooltip => "How long the server has been running since last restart",	2824	tooltip => "How long the server has been running since last restart",
…		…
2786	id => "party",	2833	id => "party",
2787	title => "Party",	2834	title => "Party",
2788	reply => "gsay ",	2835	reply => "gsay ",
2789	tooltip => "Messages and chat related to your party",	2836	tooltip => "Messages and chat related to your party",
2790	},	2837	},
		2838	"c/death" => {
		2839	id => "death",
		2840	title => "Death",
		2841	reply => undef,
		2842	tooltip => "Reason for and more info about your most recent death",
		2843	},
		2844	"c/say" => $SAY_CHANNEL,
		2845	"c/chat" => $CHAT_CHANNEL,
2791	);	2846	);
2792		2847
2793	sub cf::client::send_msg {	2848	sub cf::client::send_msg {
2794	my ($self, $channel, $msg, $color, @extra) = @_;	2849	my ($self, $channel, $msg, $color, @extra) = @_;
2795		2850
…		…
2800		2855
2801	# check predefined channels, for the benefit of C	2856	# check predefined channels, for the benefit of C
2802	if ($CHANNEL{$channel}) {	2857	if ($CHANNEL{$channel}) {
2803	$channel = $CHANNEL{$channel};	2858	$channel = $CHANNEL{$channel};
2804		2859
2805	$self->ext_msg (channel_info => $channel)	2860	$self->ext_msg (channel_info => $channel);
2806	if $self->can_msg;
2807
2808	$channel = $channel->{id};	2861	$channel = $channel->{id};
2809		2862
2810	} elsif (ref $channel) {	2863	} elsif (ref $channel) {
2811	# send meta info to client, if not yet sent	2864	# send meta info to client, if not yet sent
2812	unless (exists $self->{channel}{$channel->{id}}) {	2865	unless (exists $self->{channel}{$channel->{id}}) {
2813	$self->{channel}{$channel->{id}} = $channel;	2866	$self->{channel}{$channel->{id}} = $channel;
2814	$self->ext_msg (channel_info => $channel)	2867	$self->ext_msg (channel_info => $channel);
2815	if $self->can_msg;
2816	}	2868	}
2817		2869
2818	$channel = $channel->{id};	2870	$channel = $channel->{id};
2819	}	2871	}
2820		2872
2821	return unless @extra \|\| length $msg;	2873	return unless @extra \|\| length $msg;
2822		2874
2823	if ($self->can_msg) {
2824	# default colour, mask it out	2875	# default colour, mask it out
2825	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)	2876	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
2826	if $color & cf::NDI_DEF;	2877	if $color & cf::NDI_DEF;
2827		2878
2828	my $pkt = "msg "	2879	my $pkt = "msg "
2829	. $self->{json_coder}->encode (	2880	. $self->{json_coder}->encode (
2830	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]	2881	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]
2831	);	2882	);
2832		2883
2833	# try lzf for large packets	2884	# try lzf for large packets
2834	$pkt = "lzf " . Compress::LZF::compress $pkt	2885	$pkt = "lzf " . Compress::LZF::compress $pkt
2835	if 1024 <= length $pkt and $self->{can_lzf};	2886	if 1024 <= length $pkt and $self->{can_lzf};
2836		2887
2837	# split very large packets	2888	# split very large packets
2838	if (8192 < length $pkt and $self->{can_lzf}) {	2889	if (8192 < length $pkt and $self->{can_lzf}) {
2839	$self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;	2890	$self->send_packet ("frag $_") for unpack "(a8192)*", $pkt;
2840	$pkt = "frag";	2891	$pkt = "frag";
2841	}	2892	}
2842		2893
2843	$self->send_packet ($pkt);	2894	$self->send_packet ($pkt);
2844	} else {
2845	if ($color >= 0) {
2846	# replace some tags by gcfclient-compatible ones
2847	for ($msg) {
2848	1 while
2849	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2850	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2851	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2852	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2853	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2854	}
2855
2856	$color &= cf::NDI_COLOR_MASK;
2857
2858	utf8::encode $msg;
2859
2860	if (0 && $msg =~ /\[/) {
2861	# COMMAND/INFO
2862	$self->send_packet ("drawextinfo $color 10 8 $msg")
2863	} else {
2864	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2865	$self->send_packet ("drawinfo $color $msg")
2866	}
2867	}
2868	}
2869	}	2895	}
2870		2896
2871	=item $client->ext_msg ($type, @msg)	2897	=item $client->ext_msg ($type, @msg)
2872		2898
2873	Sends an ext event to the client.	2899	Sends an ext event to the client.
…		…
3048	The following functions and methods are available within a safe environment:	3074	The following functions and methods are available within a safe environment:
3049		3075
3050	cf::object	3076	cf::object
3051	contr pay_amount pay_player map x y force_find force_add destroy	3077	contr pay_amount pay_player map x y force_find force_add destroy
3052	insert remove name archname title slaying race decrease split	3078	insert remove name archname title slaying race decrease split
		3079	value
3053		3080
3054	cf::object::player	3081	cf::object::player
3055	player	3082	player
3056		3083
3057	cf::player	3084	cf::player
…		…
3063	=cut	3090	=cut
3064		3091
3065	for (	3092	for (
3066	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	3093	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
3067	insert remove inv nrof name archname title slaying race	3094	insert remove inv nrof name archname title slaying race
3068	decrease split destroy change_exp)],	3095	decrease split destroy change_exp value msg lore send_msg)],
3069	["cf::object::player" => qw(player)],	3096	["cf::object::player" => qw(player)],
3070	["cf::player" => qw(peaceful)],	3097	["cf::player" => qw(peaceful send_msg)],
3071	["cf::map" => qw(trigger)],	3098	["cf::map" => qw(trigger)],
3072	) {	3099	) {
3073	no strict 'refs';	3100	no strict 'refs';
3074	my ($pkg, @funs) = @$_;	3101	my ($pkg, @funs) = @$_;
3075	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})	3102	*{"safe::$pkg\::$_"} = $safe_hole->wrap (\&{"$pkg\::$_"})
…		…
3092	my ($code, %vars) = @_;	3119	my ($code, %vars) = @_;
3093		3120
3094	my $qcode = $code;	3121	my $qcode = $code;
3095	$qcode =~ s/"/‟/g; # not allowed in #line filenames	3122	$qcode =~ s/"/‟/g; # not allowed in #line filenames
3096	$qcode =~ s/\n/\\n/g;	3123	$qcode =~ s/\n/\\n/g;
		3124
		3125	%vars = (_dummy => 0) unless %vars;
3097		3126
3098	local $_;	3127	local $_;
3099	local @safe::cf::_safe_eval_args = values %vars;	3128	local @safe::cf::_safe_eval_args = values %vars;
3100		3129
3101	my $eval =	3130	my $eval =
…		…
3331	reload_treasures;	3360	reload_treasures;
3332		3361
3333	warn "finished reloading resource files\n";	3362	warn "finished reloading resource files\n";
3334	}	3363	}
3335		3364
3336	sub init {
3337	my $guard = freeze_mainloop;
3338
3339	evthread_start IO::AIO::poll_fileno;
3340
3341	reload_resources;
3342	}
3343
3344	sub reload_config {	3365	sub reload_config {
3345	open my $fh, "<:utf8", "$CONFDIR/config"	3366	open my $fh, "<:utf8", "$CONFDIR/config"
3346	or return;	3367	or return;
3347		3368
3348	local $/;	3369	local $/;
…		…
3380	seek $fh, 0, 0;	3401	seek $fh, 0, 0;
3381	print $fh $$;	3402	print $fh $$;
3382	}	3403	}
3383		3404
3384	sub main {	3405	sub main {
3385	atomic;	3406	cf::init_globals; # initialise logging
		3407
		3408	LOG llevInfo, "Welcome to Deliantra, v" . VERSION;
		3409	LOG llevInfo, "Copyright (C) 2005-2008 Marc Alexander Lehmann / Robin Redeker / the Deliantra team.";
		3410	LOG llevInfo, "Copyright (C) 1994 Mark Wedel.";
		3411	LOG llevInfo, "Copyright (C) 1992 Frank Tore Johansen.";
		3412
		3413	cf::init_experience;
		3414	cf::init_anim;
		3415	cf::init_attackmess;
		3416	cf::init_dynamic;
		3417
		3418	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3386		3419
3387	# we must not ever block the main coroutine	3420	# we must not ever block the main coroutine
3388	local $Coro::idle = sub {	3421	local $Coro::idle = sub {
3389	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#	3422	Carp::cluck "FATAL: Coro::idle was called, major BUG, use cf::sync_job!\n";#d#
3390	(async {	3423	(async {
3391	$Coro::current->{desc} = "IDLE BUG HANDLER";	3424	$Coro::current->{desc} = "IDLE BUG HANDLER";
3392	EV::loop EV::LOOP_ONESHOT;	3425	EV::loop EV::LOOP_ONESHOT;
3393	})->prio (Coro::PRIO_MAX);	3426	})->prio (Coro::PRIO_MAX);
3394	};	3427	};
3395		3428
3396	{	3429	evthread_start IO::AIO::poll_fileno;
3397	my $guard = freeze_mainloop;	3430
		3431	cf::sync_job {
		3432	reload_resources;
3398	reload_config;	3433	reload_config;
3399	db_init;	3434	db_init;
		3435
		3436	cf::load_settings;
		3437	cf::load_materials;
		3438	cf::init_uuid;
		3439	cf::init_signals;
		3440	cf::init_commands;
		3441	cf::init_skills;
		3442
		3443	cf::init_beforeplay;
		3444
		3445	atomic;
		3446
3400	load_extensions;	3447	load_extensions;
3401		3448
3402	$Coro::current->prio (Coro::PRIO_MAX); # give the main loop max. priority
3403	}
3404
3405	utime time, time, $RUNTIMEFILE;	3449	utime time, time, $RUNTIMEFILE;
3406		3450
3407	# no (long-running) fork's whatsoever before this point(!)	3451	# no (long-running) fork's whatsoever before this point(!)
3408	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};	3452	POSIX::close delete $ENV{LOCKUTIL_LOCK_FD} if exists $ENV{LOCKUTIL_LOCK_FD};
		3453
		3454	(pop @POST_INIT)->(0) while @POST_INIT;
		3455	};
3409		3456
3410	EV::loop;	3457	EV::loop;
3411	}	3458	}
3412		3459
3413	#############################################################################	3460	#############################################################################
…		…
3471	my $uuid = "$LOCALDIR/uuid";	3518	my $uuid = "$LOCALDIR/uuid";
3472		3519
3473	my $fh = aio_open "$uuid~", O_WRONLY \| O_CREAT, 0644	3520	my $fh = aio_open "$uuid~", O_WRONLY \| O_CREAT, 0644
3474	or return;	3521	or return;
3475		3522
3476	my $value = uuid_str $uuid_skip + uuid_seq uuid_cur;	3523	my $value = uuid_seq uuid_cur;
		3524
		3525	unless ($value) {
		3526	warn "cowardly refusing to write zero uuid value!\n";
		3527	return;
		3528	}
		3529
		3530	my $value = uuid_str $value + $uuid_skip;
3477	$uuid_skip = 0;	3531	$uuid_skip = 0;
3478		3532
3479	(aio_write $fh, 0, (length $value), $value, 0) <= 0	3533	(aio_write $fh, 0, (length $value), $value, 0) <= 0
3480	and return;	3534	and return;
3481		3535
…		…
3503	}	3557	}
3504		3558
3505	sub emergency_save() {	3559	sub emergency_save() {
3506	my $freeze_guard = cf::freeze_mainloop;	3560	my $freeze_guard = cf::freeze_mainloop;
3507		3561
3508	warn "enter emergency perl save\n";	3562	warn "emergency_perl_save: enter\n";
3509		3563
3510	cf::sync_job {	3564	cf::sync_job {
		3565	# this is a trade-off: we want to be very quick here, so
		3566	# save all maps without fsync, and later call a global sync
		3567	# (which in turn might be very very slow)
		3568	local $USE_FSYNC = 0;
		3569
3511	# use a peculiar iteration method to avoid tripping on perl	3570	# use a peculiar iteration method to avoid tripping on perl
3512	# refcount bugs in for. also avoids problems with players	3571	# refcount bugs in for. also avoids problems with players
3513	# and maps saved/destroyed asynchronously.	3572	# and maps saved/destroyed asynchronously.
3514	warn "begin emergency player save\n";	3573	warn "emergency_perl_save: begin player save\n";
3515	for my $login (keys %cf::PLAYER) {	3574	for my $login (keys %cf::PLAYER) {
3516	my $pl = $cf::PLAYER{$login} or next;	3575	my $pl = $cf::PLAYER{$login} or next;
3517	$pl->valid or next;	3576	$pl->valid or next;
3518	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt	3577	delete $pl->{unclean_save}; # not strictly necessary, but cannot hurt
3519	$pl->save;	3578	$pl->save;
3520	}	3579	}
3521	warn "end emergency player save\n";	3580	warn "emergency_perl_save: end player save\n";
3522		3581
3523	warn "begin emergency map save\n";	3582	warn "emergency_perl_save: begin map save\n";
3524	for my $path (keys %cf::MAP) {	3583	for my $path (keys %cf::MAP) {
3525	my $map = $cf::MAP{$path} or next;	3584	my $map = $cf::MAP{$path} or next;
3526	$map->valid or next;	3585	$map->valid or next;
3527	$map->save;	3586	$map->save;
3528	}	3587	}
3529	warn "end emergency map save\n";	3588	warn "emergency_perl_save: end map save\n";
3530		3589
3531	warn "begin emergency database checkpoint\n";	3590	warn "emergency_perl_save: begin database checkpoint\n";
3532	BDB::db_env_txn_checkpoint $DB_ENV;	3591	BDB::db_env_txn_checkpoint $DB_ENV;
3533	warn "end emergency database checkpoint\n";	3592	warn "emergency_perl_save: end database checkpoint\n";
3534		3593
3535	warn "begin write uuid\n";	3594	warn "emergency_perl_save: begin write uuid\n";
3536	write_uuid_sync 1;	3595	write_uuid_sync 1;
3537	warn "end write uuid\n";	3596	warn "emergency_perl_save: end write uuid\n";
3538	};	3597	};
3539		3598
		3599	warn "emergency_perl_save: starting sync()\n";
		3600	IO::AIO::aio_sync sub {
		3601	warn "emergency_perl_save: finished sync()\n";
		3602	};
		3603
3540	warn "leave emergency perl save\n";	3604	warn "emergency_perl_save: leave\n";
3541	}	3605	}
3542		3606
3543	sub post_cleanup {	3607	sub post_cleanup {
3544	my ($make_core) = @_;	3608	my ($make_core) = @_;
3545		3609
…		…
3571	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};	3635	my $leaf_symtab = *{$stem_symtab->{$leaf}}{HASH};
3572	for my $name (keys %$leaf_symtab) {	3636	for my $name (keys %$leaf_symtab) {
3573	_gv_clear *{"$pkg$name"};	3637	_gv_clear *{"$pkg$name"};
3574	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};	3638	# use PApp::Util; PApp::Util::sv_dump *{"$pkg$name"};
3575	}	3639	}
3576	warn "cleared package #$pkg\n";#d#	3640	warn "cleared package $pkg\n";#d#
3577	}	3641	}
3578
3579	our $RELOAD; # how many times to reload
3580		3642
3581	sub do_reload_perl() {	3643	sub do_reload_perl() {
3582	# can/must only be called in main	3644	# can/must only be called in main
3583	if ($Coro::current != $Coro::main) {	3645	if ($Coro::current != $Coro::main) {
3584	warn "can only reload from main coroutine";	3646	warn "can only reload from main coroutine";
3585	return;	3647	return;
3586	}	3648	}
3587		3649
3588	return if $RELOAD++;	3650	return if $RELOAD++;
		3651
		3652	my $t1 = EV::time;
3589		3653
3590	while ($RELOAD) {	3654	while ($RELOAD) {
3591	warn "reloading...";	3655	warn "reloading...";
3592		3656
3593	warn "entering sync_job";	3657	warn "entering sync_job";
…		…
3654	clear_package "safe::$_"	3718	clear_package "safe::$_"
3655	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);	3719	for qw(cf::attachable cf::object cf::object::player cf::client cf::player cf::map cf::party cf::region);
3656		3720
3657	warn "unloading cf.pm \"a bit\"";	3721	warn "unloading cf.pm \"a bit\"";
3658	delete $INC{"cf.pm"};	3722	delete $INC{"cf.pm"};
3659	delete $INC{"cf/pod.pm"};	3723	delete $INC{"cf/$_.pm"} for @EXTRA_MODULES;
3660		3724
3661	# don't, removes xs symbols, too,	3725	# don't, removes xs symbols, too,
3662	# and global variables created in xs	3726	# and global variables created in xs
3663	#clear_package __PACKAGE__;	3727	#clear_package __PACKAGE__;
3664		3728
…		…
3672	cf::reload_config;	3736	cf::reload_config;
3673		3737
3674	warn "loading extensions";	3738	warn "loading extensions";
3675	cf::load_extensions;	3739	cf::load_extensions;
3676		3740
		3741	if ($REATTACH_ON_RELOAD) {
3677	warn "reattaching attachments to objects/players";	3742	warn "reattaching attachments to objects/players";
3678	_global_reattach; # objects, sockets	3743	_global_reattach; # objects, sockets
3679	warn "reattaching attachments to maps";	3744	warn "reattaching attachments to maps";
3680	reattach $_ for values %MAP;	3745	reattach $_ for values %MAP;
3681	warn "reattaching attachments to players";	3746	warn "reattaching attachments to players";
3682	reattach $_ for values %PLAYER;	3747	reattach $_ for values %PLAYER;
		3748	}
		3749
		3750	warn "running post_init jobs";
		3751	(pop @POST_INIT)->(1) while @POST_INIT;
3683		3752
3684	warn "leaving sync_job";	3753	warn "leaving sync_job";
3685		3754
3686	1	3755	1
3687	} or do {	3756	} or do {
…		…
3690	};	3759	};
3691		3760
3692	warn "reloaded";	3761	warn "reloaded";
3693	--$RELOAD;	3762	--$RELOAD;
3694	}	3763	}
		3764
		3765	$t1 = EV::time - $t1;
		3766	warn "reload completed in ${t1}s\n";
3695	};	3767	};
3696		3768
3697	our $RELOAD_WATCHER; # used only during reload	3769	our $RELOAD_WATCHER; # used only during reload
3698		3770
3699	sub reload_perl() {	3771	sub reload_perl() {
3700	# doing reload synchronously and two reloads happen back-to-back,	3772	# doing reload synchronously and two reloads happen back-to-back,
3701	# coro crashes during coro_state_free->destroy here.	3773	# coro crashes during coro_state_free->destroy here.
3702		3774
		3775	$RELOAD_WATCHER \|\|= cf::async {
		3776	Coro::AIO::aio_wait cache_extensions;
		3777
3703	$RELOAD_WATCHER \|\|= EV::timer 0, 0, sub {	3778	$RELOAD_WATCHER = EV::timer $TICK * 1.5, 0, sub {
3704	do_reload_perl;	3779	do_reload_perl;
3705	undef $RELOAD_WATCHER;	3780	undef $RELOAD_WATCHER;
		3781	};
3706	};	3782	};
3707	}	3783	}
3708		3784
3709	register_command "reload" => sub {	3785	register_command "reload" => sub {
3710	my ($who, $arg) = @_;	3786	my ($who, $arg) = @_;
…		…
3869	LOG llevInfo, "[ABT] [suppressed]\n";	3945	LOG llevInfo, "[ABT] [suppressed]\n";
3870	}	3946	}
3871	}	3947	}
3872		3948
3873	# load additional modules	3949	# load additional modules
3874	use cf::pod;	3950	require "cf/$_.pm" for @EXTRA_MODULES;
3875		3951
3876	END { cf::emergency_save }	3952	END { cf::emergency_save }
3877		3953
3878	1	3954	1
3879		3955

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.447 by root, Fri Sep 19 01:39:45 2008 UTC vs. Revision 1.473 by root, Fri Jun 26 16:32:10 2009 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.447 by root, Fri Sep 19 01:39:45 2008 UTC vs.
Revision 1.473 by root, Fri Jun 26 16:32:10 2009 UTC