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

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs.
Revision 1.354 by root, Sun Sep 2 12:26:54 2007 UTC

…		…
10	use Event;	10	use Event;
11	use Opcode;	11	use Opcode;
12	use Safe;	12	use Safe;
13	use Safe::Hole;	13	use Safe::Hole;
14		14
15	use Coro 3.61 ();	15	use Coro 3.64 ();
16	use Coro::State;	16	use Coro::State;
17	use Coro::Handle;	17	use Coro::Handle;
18	use Coro::Event;	18	use Coro::Event;
19	use Coro::Timer;	19	use Coro::Timer;
20	use Coro::Signal;	20	use Coro::Signal;
21	use Coro::Semaphore;	21	use Coro::Semaphore;
22	use Coro::AIO;	22	use Coro::AIO;
23	use Coro::Storable;	23	use Coro::Storable;
		24	use Coro::Util ();
24		25
25	use JSON::XS 1.4 ();	26	use JSON::XS ();
26	use BDB ();	27	use BDB ();
27	use Data::Dumper;	28	use Data::Dumper;
28	use Digest::MD5;	29	use Digest::MD5;
29	use Fcntl;	30	use Fcntl;
30	use YAML::Syck ();	31	use YAML::Syck ();
…		…
166	=item cf::wait_for_tick, cf::wait_for_tick_begin	167	=item cf::wait_for_tick, cf::wait_for_tick_begin
167		168
168	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only	169	These are functions that inhibit the current coroutine one tick. cf::wait_for_tick_begin only
169	returns directly I<after> the tick processing (and consequently, can only wake one process	170	returns directly I<after> the tick processing (and consequently, can only wake one process
170	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.	171	per tick), while cf::wait_for_tick wakes up all waiters after tick processing.
		172
		173	=item @cf::INVOKE_RESULTS
		174
		175	This array contains the results of the last C<invoke ()> call. When
		176	C<cf::override> is called C<@cf::INVOKE_RESULTS> is set to the parameters of
		177	that call.
171		178
172	=back	179	=back
173		180
174	=cut	181	=cut
175		182
…		…
265	Wait until the given lock is available and then acquires it and returns	272	Wait until the given lock is available and then acquires it and returns
266	a Coro::guard object. If the guard object gets destroyed (goes out of scope,	273	a Coro::guard object. If the guard object gets destroyed (goes out of scope,
267	for example when the coroutine gets canceled), the lock is automatically	274	for example when the coroutine gets canceled), the lock is automatically
268	returned.	275	returned.
269		276
		277	Locks are not recursive, locking from the same coro twice results in a
		278	deadlocked coro.
		279
270	Lock names should begin with a unique identifier (for example, cf::map::find	280	Lock names should begin with a unique identifier (for example, cf::map::find
271	uses map_find and cf::map::load uses map_load).	281	uses map_find and cf::map::load uses map_load).
272		282
273	=item $locked = cf::lock_active $string	283	=item $locked = cf::lock_active $string
274		284
…		…
314	my $guard = Coro::guard {	324	my $guard = Coro::guard {
315	$TICK_WATCHER->start;	325	$TICK_WATCHER->start;
316	};	326	};
317	$TICK_WATCHER->stop;	327	$TICK_WATCHER->stop;
318	$guard	328	$guard
		329	}
		330
		331	=item cf::get_slot $time[, $priority[, $name]]
		332
		333	Allocate $time seconds of blocking CPU time at priority C<$priority>:
		334	This call blocks and returns only when you have at least C<$time> seconds
		335	of cpu time till the next tick. The slot is only valid till the next cede.
		336
		337	The optional C<$name> can be used to identify the job to run. It might be
		338	used for statistical purposes and should identify the same time-class.
		339
		340	Useful for short background jobs.
		341
		342	=cut
		343
		344	our @SLOT_QUEUE;
		345	our $SLOT_QUEUE;
		346
		347	$SLOT_QUEUE->cancel if $SLOT_QUEUE;
		348	$SLOT_QUEUE = Coro::async {
		349	my $signal = new Coro::Signal;
		350
		351	while () {
		352	next_job:
		353	my $avail = cf::till_tick;
		354	if ($avail > 0.01) {
		355	for (0 .. $#SLOT_QUEUE) {
		356	if ($SLOT_QUEUE[$_][0] < $avail) {
		357	my $job = splice @SLOT_QUEUE, $_, 1, ();
		358	$job->[2]->send;
		359	Coro::cede;
		360	goto next_job;
		361	}
		362	}
		363	}
		364
		365	if (@SLOT_QUEUE) {
		366	# we do not use wait_For_tick() as it returns immediately when tick is inactive
		367	push @cf::WAIT_FOR_TICK, $signal;
		368	$signal->wait;
		369	} else {
		370	Coro::schedule;
		371	}
		372	}
		373	};
		374
		375	sub get_slot($;$$) {
		376	my ($time, $pri, $name) = @_;
		377
		378	$time = $TICK * .6 if $time > $TICK * .6;
		379	my $sig = new Coro::Signal;
		380
		381	push @SLOT_QUEUE, [$time, $pri, $sig, $name];
		382	@SLOT_QUEUE = sort { $b->[1] <=> $a->[1] } @SLOT_QUEUE;
		383	$SLOT_QUEUE->ready;
		384	$sig->wait;
319	}	385	}
320		386
321	=item cf::async { BLOCK }	387	=item cf::async { BLOCK }
322		388
323	Currently the same as Coro::async_pool, meaning you cannot use	389	Currently the same as Coro::async_pool, meaning you cannot use
…		…
410	Coro::Storable. May, of course, block. Note that the executed sub may	476	Coro::Storable. May, of course, block. Note that the executed sub may
411	never block itself or use any form of Event handling.	477	never block itself or use any form of Event handling.
412		478
413	=cut	479	=cut
414		480
415	sub _store_scalar {
416	open my $fh, ">", \my $buf
417	or die "fork_call: cannot open fh-to-buf in child : $!";
418	Storable::store_fd $_[0], $fh;
419	close $fh;
420
421	$buf
422	}
423
424	sub fork_call(&@) {	481	sub fork_call(&@) {
425	my ($cb, @args) = @_;	482	my ($cb, @args) = @_;
426		483
427	# socketpair my $fh1, my $fh2, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC	484	# we seemingly have to make a local copy of the whole thing,
428	# or die "socketpair: $!";	485	# otherwise perl prematurely frees the stuff :/
429	pipe my $fh1, my $fh2	486	# TODO: investigate and fix (liekly this will be rather laborious)
430	or die "pipe: $!";
431		487
432	if (my $pid = fork) {	488	my @res = Coro::Util::fork_eval {
433	close $fh2;
434
435	my $res = (Coro::Handle::unblock $fh1)->readline (undef);
436	warn "pst<$res>" unless $res =~ /^pst/;
437	$res = Coro::Storable::thaw $res;
438
439	waitpid $pid, 0; # should not block anymore, we expect the child to simply behave
440
441	Carp::confess $$res unless "ARRAY" eq ref $res;
442
443	return wantarray ? @$res : $res->[-1];
444	} else {
445	reset_signals;	489	reset_signals;
446	local $SIG{__WARN__};	490	&$cb
447	local $SIG{__DIE__};	491	}, @args;
448	# just in case, this hack effectively disables event
449	# in the child. cleaner and slower would be canceling all watchers,
450	# but this works for the time being.
451	local $Coro::idle;
452	$Coro::current->prio (Coro::PRIO_MAX);
453		492
454	eval {	493	wantarray ? @res : $res[-1]
455	close $fh1;
456
457	my @res = eval { $cb->(@args) };
458
459	syswrite $fh2, _store_scalar $@ ? \"$@" : \@res;
460	close $fh2;
461	};
462
463	warn $@ if $@;
464	_exit 0;
465	}
466	}	494	}
467		495
468	=item $value = cf::db_get $family => $key	496	=item $value = cf::db_get $family => $key
469		497
470	Returns a single value from the environment database.	498	Returns a single value from the environment database.
…		…
550	if (1) {	578	if (1) {
551	$md5 =	579	$md5 =
552	join "\x00",	580	join "\x00",
553	$processversion,	581	$processversion,
554	map {	582	map {
555	Coro::cede;	583	cf::cede_to_tick;
556	($src->[$_], Digest::MD5::md5_hex $data[$_])	584	($src->[$_], Digest::MD5::md5_hex $data[$_])
557	} 0.. $#$src;	585	} 0.. $#$src;
558		586
559		587
560	my $dbmd5 = db_get cache => "$id/md5";	588	my $dbmd5 = db_get cache => "$id/md5";
…		…
866	";	894	";
867	die if $@;	895	die if $@;
868	}	896	}
869		897
870	our $override;	898	our $override;
871	our @invoke_results = (); # referenced from .xs code. TODO: play tricks with reify and mortals?	899	our @INVOKE_RESULTS = (); # referenced from .xs code. TODO: play tricks with reify and mortals?
872		900
873	sub override {	901	sub override {
874	$override = 1;	902	$override = 1;
875	@invoke_results = ();	903	@INVOKE_RESULTS = (@_);
876	}	904	}
877		905
878	sub do_invoke {	906	sub do_invoke {
879	my $event = shift;	907	my $event = shift;
880	my $callbacks = shift;	908	my $callbacks = shift;
881		909
882	@invoke_results = ();	910	@INVOKE_RESULTS = ();
883		911
884	local $override;	912	local $override;
885		913
886	for (@$callbacks) {	914	for (@$callbacks) {
887	eval { &{$_->[1]} };	915	eval { &{$_->[1]} };
…		…
904		932
905	Generate an object-specific event with the given arguments.	933	Generate an object-specific event with the given arguments.
906		934
907	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be	935	This API is preliminary (most likely, the EVENT_CLASS_xxx prefix will be
908	removed in future versions), and there is no public API to access override	936	removed in future versions), and there is no public API to access override
909	results (if you must, access C<@cf::invoke_results> directly).	937	results (if you must, access C<@cf::INVOKE_RESULTS> directly).
910		938
911	=back	939	=back
912		940
913	=cut	941	=cut
914		942
915	#############################################################################	943	#############################################################################
916	# object support	944	# object support
		945	#
		946
		947	sub _can_merge {
		948	my ($ob1, $ob2) = @_;
		949
		950	local $Storable::canonical = 1;
		951	my $fob1 = Storable::freeze $ob1;
		952	my $fob2 = Storable::freeze $ob2;
		953
		954	$fob1 eq $fob2
		955	}
917		956
918	sub reattach {	957	sub reattach {
919	# basically do the same as instantiate, without calling instantiate	958	# basically do the same as instantiate, without calling instantiate
920	my ($obj) = @_;	959	my ($obj) = @_;
921		960
…		…
1108	my ($pl, $buf) = @_;	1147	my ($pl, $buf) = @_;
1109		1148
1110	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };	1149	my $msg = eval { $pl->ns->{json_coder}->decode ($buf) };
1111		1150
1112	if (ref $msg) {	1151	if (ref $msg) {
		1152	my ($type, $reply, @payload) =
		1153	"ARRAY" eq ref $msg
		1154	? @$msg
		1155	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		1156
		1157	my @reply;
		1158
1113	if (my $cb = $EXTCMD{$msg->{msgtype}}) {	1159	if (my $cb = $EXTCMD{$type}) {
1114	if (my %reply = $cb->($pl, $msg)) {	1160	@reply = $cb->($pl, @payload);
1115	$pl->ext_reply ($msg->{msgid}, %reply);
1116	}
1117	}	1161	}
		1162
		1163	$pl->ext_reply ($reply, @reply)
		1164	if $reply;
		1165
1118	} else {	1166	} else {
1119	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";	1167	warn "player " . ($pl->ob->name) . " sent unparseable ext message: <$buf>\n";
1120	}	1168	}
1121		1169
1122	cf::override;	1170	cf::override;
…		…
1277		1325
1278	aio_mkdir playerdir $pl, 0770;	1326	aio_mkdir playerdir $pl, 0770;
1279	$pl->{last_save} = $cf::RUNTIME;	1327	$pl->{last_save} = $cf::RUNTIME;
1280		1328
1281	$pl->save_pl ($path);	1329	$pl->save_pl ($path);
1282	Coro::cede;	1330	cf::cede_to_tick;
1283	}	1331	}
1284		1332
1285	sub new($) {	1333	sub new($) {
1286	my ($login) = @_;	1334	my ($login) = @_;
1287		1335
…		…
1291	$self->{deny_save} = 1;	1339	$self->{deny_save} = 1;
1292		1340
1293	$cf::PLAYER{$login} = $self;	1341	$cf::PLAYER{$login} = $self;
1294		1342
1295	$self	1343	$self
		1344	}
		1345
		1346	=item $player->send_msg ($channel, $msg, $color, [extra...])
		1347
		1348	=cut
		1349
		1350	sub send_msg {
		1351	my $ns = shift->ns
		1352	or return;
		1353	$ns->send_msg (@_);
1296	}	1354	}
1297		1355
1298	=item $pl->quit_character	1356	=item $pl->quit_character
1299		1357
1300	Nukes the player without looking back. If logged in, the connection will	1358	Nukes the player without looking back. If logged in, the connection will
…		…
1355	or return [];	1413	or return [];
1356		1414
1357	my @logins;	1415	my @logins;
1358		1416
1359	for my $login (@$dirs) {	1417	for my $login (@$dirs) {
		1418	my $path = path $login;
		1419
		1420	# a .pst is a dead give-away for a valid player
		1421	unless (-e "$path.pst") {
1360	my $fh = aio_open path $login, Fcntl::O_RDONLY, 0 or next;	1422	my $fh = aio_open $path, Fcntl::O_RDONLY, 0 or next;
1361	aio_read $fh, 0, 512, my $buf, 0 or next;	1423	aio_read $fh, 0, 512, my $buf, 0 or next;
1362	$buf !~ /^password -------------$/m or next; # official not-valid tag	1424	$buf !~ /^password -------------$/m or next; # official not-valid tag
		1425	}
1363		1426
1364	utf8::decode $login;	1427	utf8::decode $login;
1365	push @logins, $login;	1428	push @logins, $login;
1366	}	1429	}
1367		1430
…		…
1405	sub expand_cfpod {	1468	sub expand_cfpod {
1406	((my $self), (local $_)) = @_;	1469	((my $self), (local $_)) = @_;
1407		1470
1408	# escape & and <	1471	# escape & and <
1409	s/&/&/g;	1472	s/&/&/g;
1410	s/(?<![BIUGH])</</g;	1473	s/(?<![BIUGHT])</</g;
1411		1474
1412	# this is buggy, it needs to properly take care of nested <'s	1475	# this is buggy, it needs to properly take care of nested <'s
1413		1476
1414	1 while	1477	1 while
1415	# replace B<>, I<>, U<> etc.	1478	# replace B<>, I<>, U<> etc.
1416	s/B<([^\>]*)>/<b>$1<\/b>/	1479	s/B<([^\>]*)>/<b>$1<\/b>/
1417	\|\| s/I<([^\>]*)>/<i>$1<\/i>/	1480	\|\| s/I<([^\>]*)>/<i>$1<\/i>/
1418	\|\| s/U<([^\>]*)>/<u>$1<\/u>/	1481	\|\| s/U<([^\>]*)>/<u>$1<\/u>/
		1482	\|\| s/T<([^\>]*)>/<big><b>$1<\/b><\/big>/
1419	# replace G<male\|female> tags	1483	# replace G<male\|female> tags
1420	\|\| s{G<([^>\|])\\|([^>])>}{	1484	\|\| s{G<([^>\|])\\|([^>])>}{
1421	$self->gender ? $2 : $1	1485	$self->gender ? $2 : $1
1422	}ge	1486	}ge
1423	# replace H<hint text>	1487	# replace H<hint text>
…		…
1444	sub hintmode {	1508	sub hintmode {
1445	$_[0]{hintmode} = $_[1] if @_ > 1;	1509	$_[0]{hintmode} = $_[1] if @_ > 1;
1446	$_[0]{hintmode}	1510	$_[0]{hintmode}
1447	}	1511	}
1448		1512
1449	=item $player->ext_reply ($msgid, %msg)	1513	=item $player->ext_reply ($msgid, @msg)
1450		1514
1451	Sends an ext reply to the player.	1515	Sends an ext reply to the player.
1452		1516
1453	=cut	1517	=cut
1454		1518
1455	sub ext_reply($$%) {	1519	sub ext_reply($$@) {
1456	my ($self, $id, %msg) = @_;	1520	my ($self, $id, @msg) = @_;
1457		1521
1458	$msg{msgid} = $id;	1522	$self->ns->ext_reply ($id, @msg)
1459	$self->send ("ext " . $self->ns->{json_coder}->encode (\%msg));
1460	}	1523	}
1461		1524
1462	=item $player->ext_event ($type, %msg)	1525	=item $player->ext_msg ($type, @msg)
1463		1526
1464	Sends an ext event to the client.	1527	Sends an ext event to the client.
1465		1528
1466	=cut	1529	=cut
1467		1530
1468	sub ext_event($$%) {	1531	sub ext_msg($$@) {
1469	my ($self, $type, %msg) = @_;	1532	my ($self, $type, @msg) = @_;
1470		1533
1471	$self->ns->ext_event ($type, %msg);	1534	$self->ns->ext_msg ($type, @msg);
1472	}	1535	}
1473		1536
1474	=head3 cf::region	1537	=head3 cf::region
1475		1538
1476	=over 4	1539	=over 4
…		…
1795	local $self->{deny_reset} = 1; # loading can take a long time	1858	local $self->{deny_reset} = 1; # loading can take a long time
1796		1859
1797	my $path = $self->{path};	1860	my $path = $self->{path};
1798		1861
1799	{	1862	{
		1863	my $guard1 = cf::lock_acquire "map_data:$path";
1800	my $guard = cf::lock_acquire "map_load:$path";	1864	my $guard2 = cf::lock_acquire "map_load:$path";
1801		1865
1802	return if $self->in_memory != cf::MAP_SWAPPED;	1866	return if $self->in_memory != cf::MAP_SWAPPED;
1803		1867
1804	$self->in_memory (cf::MAP_LOADING);	1868	$self->in_memory (cf::MAP_LOADING);
1805		1869
1806	$self->alloc;	1870	$self->alloc;
1807		1871
1808	$self->pre_load;	1872	$self->pre_load;
1809	Coro::cede;	1873	cf::cede_to_tick;
1810		1874
1811	$self->_load_objects ($self->{load_path}, 1)	1875	$self->_load_objects ($self->{load_path}, 1)
1812	or return;	1876	or return;
1813		1877
1814	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)	1878	$self->set_object_flag (cf::FLAG_OBJ_ORIGINAL, 1)
…		…
1820	$self->clear_unique_items;	1884	$self->clear_unique_items;
1821	$self->_load_objects ($uniq, 0);	1885	$self->_load_objects ($uniq, 0);
1822	}	1886	}
1823	}	1887	}
1824		1888
1825	Coro::cede;	1889	cf::cede_to_tick;
1826	# now do the right thing for maps	1890	# now do the right thing for maps
1827	$self->link_multipart_objects;	1891	$self->link_multipart_objects;
1828	$self->difficulty ($self->estimate_difficulty)	1892	$self->difficulty ($self->estimate_difficulty)
1829	unless $self->difficulty;	1893	unless $self->difficulty;
1830	Coro::cede;	1894	cf::cede_to_tick;
1831		1895
1832	unless ($self->{deny_activate}) {	1896	unless ($self->{deny_activate}) {
1833	$self->decay_objects;	1897	$self->decay_objects;
1834	$self->fix_auto_apply;	1898	$self->fix_auto_apply;
1835	$self->update_buttons;	1899	$self->update_buttons;
1836	Coro::cede;	1900	cf::cede_to_tick;
1837	$self->set_darkness_map;	1901	$self->set_darkness_map;
1838	Coro::cede;	1902	cf::cede_to_tick;
1839	$self->activate;	1903	$self->activate;
1840	}	1904	}
		1905
		1906	$self->{last_save} = $cf::RUNTIME;
		1907	$self->last_access ($cf::RUNTIME);
1841		1908
1842	$self->in_memory (cf::MAP_IN_MEMORY);	1909	$self->in_memory (cf::MAP_IN_MEMORY);
1843	}	1910	}
1844		1911
1845	$self->post_load;	1912	$self->post_load;
…		…
1856		1923
1857	$self	1924	$self
1858	}	1925	}
1859		1926
1860	# find and load all maps in the 3x3 area around a map	1927	# find and load all maps in the 3x3 area around a map
1861	sub load_diag {	1928	sub load_neighbours {
1862	my ($map) = @_;	1929	my ($map) = @_;
1863		1930
1864	my @diag; # diagonal neighbours	1931	my @neigh; # diagonal neighbours
1865		1932
1866	for (0 .. 3) {	1933	for (0 .. 3) {
1867	my $neigh = $map->tile_path ($_)	1934	my $neigh = $map->tile_path ($_)
1868	or next;	1935	or next;
1869	$neigh = find $neigh, $map	1936	$neigh = find $neigh, $map
1870	or next;	1937	or next;
1871	$neigh->load;	1938	$neigh->load;
1872		1939
		1940	push @neigh,
1873	push @diag, [$neigh->tile_path (($_ + 3) % 4), $neigh],	1941	[$neigh->tile_path (($_ + 3) % 4), $neigh],
1874	[$neigh->tile_path (($_ + 1) % 4), $neigh];	1942	[$neigh->tile_path (($_ + 1) % 4), $neigh];
1875	}	1943	}
1876		1944
1877	for (@diag) {	1945	for (grep defined $_->[0], @neigh) {
		1946	my ($path, $origin) = @$_;
1878	my $neigh = find @$_	1947	my $neigh = find $path, $origin
1879	or next;	1948	or next;
1880	$neigh->load;	1949	$neigh->load;
1881	}	1950	}
1882	}	1951	}
1883		1952
…		…
1888	}	1957	}
1889		1958
1890	sub do_load_sync {	1959	sub do_load_sync {
1891	my ($map) = @_;	1960	my ($map) = @_;
1892		1961
		1962	cf::LOG cf::llevDebug \| cf::logBacktrace, "do_load_sync"
		1963	if $Coro::current == $Coro::main;
		1964
1893	cf::sync_job { $map->load };	1965	cf::sync_job { $map->load };
1894	}	1966	}
1895		1967
1896	our %MAP_PREFETCH;	1968	our %MAP_PREFETCH;
1897	our $MAP_PREFETCHER = undef;	1969	our $MAP_PREFETCHER = undef;
1898		1970
1899	sub find_async {	1971	sub find_async {
1900	my ($path, $origin) = @_;	1972	my ($path, $origin, $load) = @_;
1901		1973
1902	$path = normalise $path, $origin && $origin->{path};	1974	$path = normalise $path, $origin && $origin->{path};
1903		1975
1904	if (my $map = $cf::MAP{$path}) {	1976	if (my $map = $cf::MAP{$path}) {
1905	return $map if $map->in_memory == cf::MAP_IN_MEMORY;	1977	return $map if !$load \|\| $map->in_memory == cf::MAP_IN_MEMORY;
1906	}	1978	}
1907		1979
1908	undef $MAP_PREFETCH{$path};	1980	$MAP_PREFETCH{$path} \|= $load;
		1981
1909	$MAP_PREFETCHER \|\|= cf::async {	1982	$MAP_PREFETCHER \|\|= cf::async {
1910	while (%MAP_PREFETCH) {	1983	while (%MAP_PREFETCH) {
1911	for my $path (keys %MAP_PREFETCH) {	1984	while (my ($k, $v) = each %MAP_PREFETCH) {
1912	if (my $map = find $path) {	1985	if (my $map = find $k) {
1913	$map->load;	1986	$map->load if $v;
1914	}	1987	}
1915		1988
1916	delete $MAP_PREFETCH{$path};	1989	delete $MAP_PREFETCH{$k};
1917	}	1990	}
1918	}	1991	}
1919	undef $MAP_PREFETCHER;	1992	undef $MAP_PREFETCHER;
1920	};	1993	};
1921	$MAP_PREFETCHER->prio (6);	1994	$MAP_PREFETCHER->prio (6);
…		…
1924	}	1997	}
1925		1998
1926	sub save {	1999	sub save {
1927	my ($self) = @_;	2000	my ($self) = @_;
1928		2001
1929	my $lock = cf::lock_acquire "map_data:" . $self->path;	2002	my $lock = cf::lock_acquire "map_data:$self->{path}";
1930		2003
1931	$self->{last_save} = $cf::RUNTIME;	2004	$self->{last_save} = $cf::RUNTIME;
1932		2005
1933	return unless $self->dirty;	2006	return unless $self->dirty;
1934		2007
…		…
1957	my ($self) = @_;	2030	my ($self) = @_;
1958		2031
1959	# save first because save cedes	2032	# save first because save cedes
1960	$self->save;	2033	$self->save;
1961		2034
1962	my $lock = cf::lock_acquire "map_data:" . $self->path;	2035	my $lock = cf::lock_acquire "map_data:$self->{path}";
1963		2036
1964	return if $self->players;	2037	return if $self->players;
1965	return if $self->in_memory != cf::MAP_IN_MEMORY;	2038	return if $self->in_memory != cf::MAP_IN_MEMORY;
1966	return if $self->{deny_save};	2039	return if $self->{deny_save};
1967		2040
…		…
2019	my $nuke_counter = "aaaa";	2092	my $nuke_counter = "aaaa";
2020		2093
2021	sub nuke {	2094	sub nuke {
2022	my ($self) = @_;	2095	my ($self) = @_;
2023		2096
		2097	{
		2098	my $lock = cf::lock_acquire "map_data:$self->{path}";
		2099
2024	delete $cf::MAP{$self->path};	2100	delete $cf::MAP{$self->path};
2025		2101
2026	$self->unlink_save;	2102	$self->unlink_save;
2027		2103
2028	bless $self, "cf::map";	2104	bless $self, "cf::map";
2029	delete $self->{deny_reset};	2105	delete $self->{deny_reset};
2030	$self->{deny_save} = 1;	2106	$self->{deny_save} = 1;
2031	$self->reset_timeout (1);	2107	$self->reset_timeout (1);
2032	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));	2108	$self->path ($self->{path} = "{nuke}/" . ($nuke_counter++));
2033		2109
2034	$cf::MAP{$self->path} = $self;	2110	$cf::MAP{$self->path} = $self;
		2111	}
2035		2112
2036	$self->reset; # polite request, might not happen	2113	$self->reset; # polite request, might not happen
2037	}	2114	}
2038		2115
2039	=item $maps = cf::map::tmp_maps	2116	=item $maps = cf::map::tmp_maps
…		…
2146		2223
2147	} else {	2224	} else {
2148	my $pl = $self->contr;	2225	my $pl = $self->contr;
2149		2226
2150	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {	2227	if ($pl->{npc_dialog} && $pl->{npc_dialog}->{id}) {
2151	my $diag = $pl->{npc_dialog};	2228	my $dialog = $pl->{npc_dialog};
2152	$diag->{pl}->ext_reply (	2229	$dialog->{pl}->ext_msg ($dialog->{id}, update => msg => $dialog->{pl}->expand_cfpod ($msg));
2153	$diag->{id},
2154	msgtype => "reply",
2155	msg => $diag->{pl}->expand_cfpod ($msg),
2156	add_topics => []
2157	);
2158		2230
2159	} else {	2231	} else {
2160	$msg = $npc->name . " says: $msg" if $npc;	2232	$msg = $npc->name . " says: $msg" if $npc;
2161	$self->message ($msg, $flags);	2233	$self->message ($msg, $flags);
2162	}	2234	}
2163	}	2235	}
		2236	}
		2237
		2238	=item $object->send_msg ($channel, $msg, $color, [extra...])
		2239
		2240	=cut
		2241
		2242	sub cf::object::send_msg {
		2243	my $pl = shift->contr
		2244	or return;
		2245	$pl->send_msg (@_);
2164	}	2246	}
2165		2247
2166	=item $player_object->may ("access")	2248	=item $player_object->may ("access")
2167		2249
2168	Returns wether the given player is authorized to access resource "access"	2250	Returns wether the given player is authorized to access resource "access"
…		…
2247	# use -1 or undef as default coordinates, not 0, 0	2329	# use -1 or undef as default coordinates, not 0, 0
2248	($x, $y) = ($map->enter_x, $map->enter_y)	2330	($x, $y) = ($map->enter_x, $map->enter_y)
2249	if $x <=0 && $y <= 0;	2331	if $x <=0 && $y <= 0;
2250		2332
2251	$map->load;	2333	$map->load;
2252	$map->load_diag;	2334	$map->load_neighbours;
2253		2335
2254	return unless $self->contr->active;	2336	return unless $self->contr->active;
2255	$self->activate_recursive;	2337	$self->activate_recursive;
2256		2338
2257	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext	2339	local $self->{_prev_pos} = $link_pos; # ugly hack for rent.ext
…		…
2419		2501
2420	utf8::encode $text;	2502	utf8::encode $text;
2421	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);	2503	$self->send_packet (sprintf "drawinfo %d %s", $flags \|\| cf::NDI_BLACK, $text);
2422	}	2504	}
2423		2505
2424	=item $client->send_msg ($color, $type, $msg, [extra...])	2506	=item $client->send_msg ($channel, $msg, $color, [extra...])
2425		2507
2426	Send a drawinfo or msg packet to the client, formatting the msg for the	2508	Send a drawinfo or msg packet to the client, formatting the msg for the
2427	client if neccessary. C<$type> should be a string identifying the type of	2509	client if neccessary. C<$type> should be a string identifying the type of
2428	the message, with C<log> being the default. If C<$color> is negative, suppress	2510	the message, with C<log> being the default. If C<$color> is negative, suppress
2429	the message unless the client supports the msg packet.	2511	the message unless the client supports the msg packet.
2430		2512
2431	=cut	2513	=cut
2432		2514
		2515	our %CHANNEL = (
		2516	"c/identify" => {
		2517	id => "identify",
		2518	title => "Identify",
		2519	reply => undef,
		2520	tooltip => "Items recently identified",
		2521	},
		2522	"c/examine" => {
		2523	id => "examine",
		2524	title => "Examine",
		2525	reply => undef,
		2526	tooltip => "Signs and other items you examined",
		2527	},
		2528	);
		2529
2433	sub cf::client::send_msg {	2530	sub cf::client::send_msg {
2434	my ($self, $color, $type, $msg, @extra) = @_;	2531	my ($self, $channel, $msg, $color, @extra) = @_;
2435		2532
2436	$msg = $self->pl->expand_cfpod ($msg);	2533	$msg = $self->pl->expand_cfpod ($msg);
2437		2534
		2535	$color &= cf::NDI_CLIENT_MASK; # just in case...
		2536
		2537	# check predefined channels, for the benefit of C
		2538	$channel = $CHANNEL{$channel} if $CHANNEL{$channel};
		2539
		2540	if (ref $channel) {
		2541	# send meta info to client, if not yet sent
		2542	unless (exists $self->{channel}{$channel->{id}}) {
		2543	$self->{channel}{$channel->{id}} = $channel;
		2544	$self->ext_msg (channel_info => $channel)
		2545	if $self->can_msg;
		2546	}
		2547
		2548	$channel = $channel->{id};
		2549	}
		2550
2438	return unless @extra \|\| length $msg;	2551	return unless @extra \|\| length $msg;
2439		2552
2440	if ($self->can_msg) {	2553	if ($self->can_msg) {
		2554	# default colour, mask it out
		2555	$color &= ~(cf::NDI_COLOR_MASK \| cf::NDI_DEF)
		2556	if $color & cf::NDI_DEF;
		2557
2441	$self->send_packet ("msg " . $self->{json_coder}->encode ([$color, $type, $msg, @extra]));	2558	$self->send_packet ("msg " . $self->{json_coder}->encode (
		2559	[$color & cf::NDI_CLIENT_MASK, $channel, $msg, @extra]));
2442	} else {	2560	} else {
2443	# replace some tags by gcfclient-compatible ones
2444	for ($msg) {
2445	1 while
2446	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
2447	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
2448	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
2449	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
2450	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
2451	}
2452
2453	if ($color >= 0) {	2561	if ($color >= 0) {
		2562	# replace some tags by gcfclient-compatible ones
		2563	for ($msg) {
		2564	1 while
		2565	s/<b>([^<]*)<\/b>/[b]${1}[\/b]/
		2566	\|\| s/<i>([^<]*)<\/i>/[i]${1}[\/i]/
		2567	\|\| s/<u>([^<]*)<\/u>/[ul]${1}[\/ul]/
		2568	\|\| s/<tt>([^<]*)<\/tt>/[fixed]${1}[\/fixed]/
		2569	\|\| s/<fg name=\"([^"]+)\">([^<]*)<\/fg>/[color=$1]${2}[\/color]/;
		2570	}
		2571
		2572	$color &= cf::NDI_COLOR_MASK;
		2573
		2574	utf8::encode $msg;
		2575
2454	if (0 && $msg =~ /\[/) {	2576	if (0 && $msg =~ /\[/) {
		2577	# COMMAND/INFO
2455	$self->send_packet ("drawextinfo $color 4 0 $msg")	2578	$self->send_packet ("drawextinfo $color 10 8 $msg")
2456	} else {	2579	} else {
2457	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;	2580	$msg =~ s/\[\/?(?:b\|i\|u\|fixed\|color)[^\]]*\]//g;
2458	$self->send_packet ("drawinfo $color $msg")	2581	$self->send_packet ("drawinfo $color $msg")
2459	}	2582	}
2460	}	2583	}
2461	}	2584	}
2462	}	2585	}
2463		2586
2464	=item $client->ext_event ($type, %msg)	2587	=item $client->ext_msg ($type, @msg)
2465		2588
2466	Sends an ext event to the client.	2589	Sends an ext event to the client.
2467		2590
2468	=cut	2591	=cut
2469		2592
2470	sub cf::client::ext_event($$%) {	2593	sub cf::client::ext_msg($$@) {
2471	my ($self, $type, %msg) = @_;	2594	my ($self, $type, @msg) = @_;
2472		2595
2473	return unless $self->extcmd;	2596	if ($self->extcmd == 2) {
2474		2597	$self->send_packet ("ext " . $self->{json_coder}->encode ([$type, @msg]));
		2598	} elsif ($self->extcmd == 1) { # TODO: remove
2475	$msg{msgtype} = "event_$type";	2599	push @msg, msgtype => "event_$type";
2476	$self->send_packet ("ext " . $self->{json_coder}->encode (\%msg));	2600	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2601	}
		2602	}
		2603
		2604	=item $client->ext_reply ($msgid, @msg)
		2605
		2606	Sends an ext reply to the client.
		2607
		2608	=cut
		2609
		2610	sub cf::client::ext_reply($$@) {
		2611	my ($self, $id, @msg) = @_;
		2612
		2613	if ($self->extcmd == 2) {
		2614	$self->send_packet ("ext " . $self->{json_coder}->encode (["reply-$id", @msg]));
		2615	} elsif ($self->extcmd == 1) {
		2616	#TODO: version 1, remove
		2617	unshift @msg, msgtype => "reply", msgid => $id;
		2618	$self->send_packet ("ext " . $self->{json_coder}->encode ({@msg}));
		2619	}
2477	}	2620	}
2478		2621
2479	=item $success = $client->query ($flags, "text", \&cb)	2622	=item $success = $client->query ($flags, "text", \&cb)
2480		2623
2481	Queues a query to the client, calling the given callback with	2624	Queues a query to the client, calling the given callback with
…		…
2536	my ($ns, $buf) = @_;	2679	my ($ns, $buf) = @_;
2537		2680
2538	my $msg = eval { $ns->{json_coder}->decode ($buf) };	2681	my $msg = eval { $ns->{json_coder}->decode ($buf) };
2539		2682
2540	if (ref $msg) {	2683	if (ref $msg) {
		2684	my ($type, $reply, @payload) =
		2685	"ARRAY" eq ref $msg
		2686	? @$msg
		2687	: ($msg->{msgtype}, $msg->{msgid}, %$msg); # TODO: version 1, remove
		2688
		2689	my @reply;
		2690
2541	if (my $cb = $EXTICMD{$msg->{msgtype}}) {	2691	if (my $cb = $EXTICMD{$type}) {
2542	if (my %reply = $cb->($ns, $msg)) {	2692	@reply = $cb->($ns, @payload);
2543	$reply{msgid} = $msg->{msgid};
2544	$ns->send ("ext " . $ns->{json_coder}->encode (\%reply));
2545	}
2546	}	2693	}
		2694
		2695	$ns->ext_reply ($reply, @reply)
		2696	if $reply;
		2697
2547	} else {	2698	} else {
2548	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";	2699	warn "client " . ($ns->pl ? $ns->pl->ob->name : $ns->host) . " sent unparseable exti message: <$buf>\n";
2549	}	2700	}
2550		2701
2551	cf::override;	2702	cf::override;
…		…
2598	our $safe = new Safe "safe";	2749	our $safe = new Safe "safe";
2599	our $safe_hole = new Safe::Hole;	2750	our $safe_hole = new Safe::Hole;
2600		2751
2601	$SIG{FPE} = 'IGNORE';	2752	$SIG{FPE} = 'IGNORE';
2602		2753
2603	$safe->permit_only (Opcode::opset qw(:base_core :base_mem :base_orig :base_math sort time));	2754	$safe->permit_only (Opcode::opset qw(
		2755	:base_core :base_mem :base_orig :base_math
		2756	grepstart grepwhile mapstart mapwhile
		2757	sort time
		2758	));
2604		2759
2605	# here we export the classes and methods available to script code	2760	# here we export the classes and methods available to script code
2606		2761
2607	=pod	2762	=pod
2608		2763
2609	The following functions and methods are available within a safe environment:	2764	The following functions and methods are available within a safe environment:
2610		2765
2611	cf::object	2766	cf::object
2612	contr pay_amount pay_player map x y force_find force_add	2767	contr pay_amount pay_player map x y force_find force_add
2613	insert remove	2768	insert remove name archname title slaying race decrease_ob_nr
2614		2769
2615	cf::object::player	2770	cf::object::player
2616	player	2771	player
2617		2772
2618	cf::player	2773	cf::player
…		…
2623		2778
2624	=cut	2779	=cut
2625		2780
2626	for (	2781	for (
2627	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y	2782	["cf::object" => qw(contr pay_amount pay_player map force_find force_add x y
		2783	insert remove inv name archname title slaying race
2628	insert remove)],	2784	decrease_ob_nr)],
2629	["cf::object::player" => qw(player)],	2785	["cf::object::player" => qw(player)],
2630	["cf::player" => qw(peaceful)],	2786	["cf::player" => qw(peaceful)],
2631	["cf::map" => qw(trigger)],	2787	["cf::map" => qw(trigger)],
2632	) {	2788	) {
2633	no strict 'refs';	2789	no strict 'refs';
…		…
2709	# the server's init and main functions	2865	# the server's init and main functions
2710		2866
2711	sub load_facedata($) {	2867	sub load_facedata($) {
2712	my ($path) = @_;	2868	my ($path) = @_;
2713		2869
		2870	# HACK to clear player env face cache, we need some signal framework
		2871	# for this (global event?)
		2872	%ext::player_env::MUSIC_FACE_CACHE = ();
		2873
		2874	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		2875
2714	warn "loading facedata from $path\n";	2876	warn "loading facedata from $path\n";
2715		2877
2716	my $facedata;	2878	my $facedata;
2717	0 < aio_load $path, $facedata	2879	0 < aio_load $path, $facedata
2718	or die "$path: $!";	2880	or die "$path: $!";
2719		2881
2720	$facedata = Coro::Storable::thaw $facedata;	2882	$facedata = Coro::Storable::thaw $facedata;
2721		2883
2722	$facedata->{version} == 2	2884	$facedata->{version} == 2
2723	or cf::cleanup "$path: version mismatch, cannot proceed.";	2885	or cf::cleanup "$path: version mismatch, cannot proceed.";
		2886
		2887	# patch in the exptable
		2888	$facedata->{resource}{"res/exp_table"} = {
		2889	type => FT_RSRC,
		2890	data => $enc->encode ([map cf::level_to_min_exp $_, 1 .. cf::settings->max_level]),
		2891	};
		2892	cf::cede_to_tick;
2724		2893
2725	{	2894	{
2726	my $faces = $facedata->{faceinfo};	2895	my $faces = $facedata->{faceinfo};
2727		2896
2728	while (my ($face, $info) = each %$faces) {	2897	while (my ($face, $info) = each %$faces) {
2729	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;	2898	my $idx = (cf::face::find $face) \|\| cf::face::alloc $face;
2730	cf::face::set_visibility $idx, $info->{visibility};	2899	cf::face::set_visibility $idx, $info->{visibility};
2731	cf::face::set_magicmap $idx, $info->{magicmap};	2900	cf::face::set_magicmap $idx, $info->{magicmap};
2732	cf::face::set_data $idx, 0, $info->{data32}, $info->{chksum32};	2901	cf::face::set_data $idx, 0, $info->{data32}, Digest::MD5::md5 $info->{data32};
2733	cf::face::set_data $idx, 1, $info->{data64}, $info->{chksum64};	2902	cf::face::set_data $idx, 1, $info->{data64}, Digest::MD5::md5 $info->{data64};
2734		2903
2735	cf::cede_to_tick;	2904	cf::cede_to_tick;
2736	}	2905	}
2737		2906
2738	while (my ($face, $info) = each %$faces) {	2907	while (my ($face, $info) = each %$faces) {
…		…
2763		2932
2764	{	2933	{
2765	# TODO: for gcfclient pleasure, we should give resources	2934	# TODO: for gcfclient pleasure, we should give resources
2766	# that gcfclient doesn't grok a >10000 face index.	2935	# that gcfclient doesn't grok a >10000 face index.
2767	my $res = $facedata->{resource};	2936	my $res = $facedata->{resource};
2768	my $enc = JSON::XS->new->utf8->canonical;	2937
		2938	my $soundconf = delete $res->{"res/sound.conf"};
2769		2939
2770	while (my ($name, $info) = each %$res) {	2940	while (my ($name, $info) = each %$res) {
2771	my $meta = $enc->encode ({
2772	name => $name,
2773	type => $info->{type},
2774	copyright => $info->{copyright}, #TODO#
2775	});
2776
2777	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;	2941	my $idx = (cf::face::find $name) \|\| cf::face::alloc $name;
		2942	my $data;
2778		2943
2779	if ($name =~ /\.jpg$/) {	2944	if ($info->{type} & 1) {
2780	cf::face::set_data $idx, 0, $info->{data}, $info->{chksum};#d# temp hack	2945	# prepend meta info
2781	cf::face::set_data $idx, 1, $info->{data}, $info->{chksum};#d# temp hack	2946
		2947	my $meta = $enc->encode ({
		2948	name => $name,
		2949	%{ $info->{meta} \|\| {} },
		2950	});
		2951
		2952	$data = pack "(w/a)", $meta, $info->{data};
2782	} else {	2953	} else {
2783	my $data = pack "(w/a)", $meta, $info->{data};	2954	$data = $info->{data};
2784	my $chk = Digest::MD5::md5 "$info->{chksum},$meta"; # mangle data checksum and metadata
2785
2786	cf::face::set_type $idx, 1;
2787	cf::face::set_data $idx, 0, $data, $chk;
2788	}	2955	}
2789		2956
		2957	cf::face::set_data $idx, 0, $data, Digest::MD5::md5 $data;
		2958	cf::face::set_type $idx, $info->{type};
		2959
2790	cf::cede_to_tick;	2960	cf::cede_to_tick;
2791	}	2961	}
		2962
		2963	if ($soundconf) {
		2964	$soundconf = $enc->decode (delete $soundconf->{data});
		2965
		2966	for (0 .. SOUND_CAST_SPELL_0 - 1) {
		2967	my $sound = $soundconf->{compat}[$_]
		2968	or next;
		2969
		2970	my $face = cf::face::find "sound/$sound->[1]";
		2971	cf::sound::set $sound->[0] => $face;
		2972	cf::sound::old_sound_index $_, $face; # gcfclient-compat
		2973	}
		2974
		2975	while (my ($k, $v) = each %{$soundconf->{event}}) {
		2976	my $face = cf::face::find "sound/$v";
		2977	cf::sound::set $k => $face;
		2978	}
		2979	}
2792	}	2980	}
2793		2981
2794	1	2982	1
2795	}	2983	}
2796		2984
		2985	register_exticmd fx_want => sub {
		2986	my ($ns, $want) = @_;
		2987
		2988	while (my ($k, $v) = each %$want) {
		2989	$ns->fx_want ($k, $v);
		2990	}
		2991	};
		2992
2797	sub reload_regions {	2993	sub reload_regions {
		2994	# HACK to clear player env face cache, we need some signal framework
		2995	# for this (global event?)
		2996	%ext::player_env::MUSIC_FACE_CACHE = ();
		2997
2798	load_resource_file "$MAPDIR/regions"	2998	load_resource_file "$MAPDIR/regions"
2799	or die "unable to load regions file\n";	2999	or die "unable to load regions file\n";
2800		3000
2801	for (cf::region::list) {	3001	for (cf::region::list) {
2802	$_->{match} = qr/$_->{match}/	3002	$_->{match} = qr/$_->{match}/
…		…
2838		3038
2839	sub init {	3039	sub init {
2840	reload_resources;	3040	reload_resources;
2841	}	3041	}
2842		3042
2843	sub cfg_load {	3043	sub reload_config {
2844	open my $fh, "<:utf8", "$CONFDIR/config"	3044	open my $fh, "<:utf8", "$CONFDIR/config"
2845	or return;	3045	or return;
2846		3046
2847	local $/;	3047	local $/;
2848	*CFG = YAML::Syck::Load <$fh>;	3048	*CFG = YAML::Syck::Load <$fh>;
…		…
2868	(async {	3068	(async {
2869	Event::one_event;	3069	Event::one_event;
2870	})->prio (Coro::PRIO_MAX);	3070	})->prio (Coro::PRIO_MAX);
2871	};	3071	};
2872		3072
2873	cfg_load;	3073	reload_config;
2874	db_init;	3074	db_init;
2875	load_extensions;	3075	load_extensions;
2876		3076
2877	$TICK_WATCHER->start;	3077	$TICK_WATCHER->start;
2878	Event::loop;	3078	Event::loop;
…		…
3071	warn "reloading cf.pm";	3271	warn "reloading cf.pm";
3072	require cf;	3272	require cf;
3073	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt	3273	cf::_connect_to_perl; # nominally unnecessary, but cannot hurt
3074		3274
3075	warn "loading config and database again";	3275	warn "loading config and database again";
3076	cf::cfg_load;	3276	cf::reload_config;
3077		3277
3078	warn "loading extensions";	3278	warn "loading extensions";
3079	cf::load_extensions;	3279	cf::load_extensions;
3080		3280
3081	warn "reattaching attachments to objects/players";	3281	warn "reattaching attachments to objects/players";

Diff Legend

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

Comparing deliantra/server/lib/cf.pm (file contents): Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs. Revision 1.354 by root, Sun Sep 2 12:26:54 2007 UTC

Diff Legend

Comparing deliantra/server/lib/cf.pm (file contents):
Revision 1.308 by root, Mon Jul 16 14:09:40 2007 UTC vs.
Revision 1.354 by root, Sun Sep 2 12:26:54 2007 UTC