[ViewVC] Diff of: cvs/deliantra/server/utils/cfutil.in

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.38 by root, Thu Jul 12 08:40:14 2007 UTC vs.
Revision 1.116 by root, Sun May 15 20:14:30 2011 UTC

…		…
1	#!@PERL@	1	#!@PERL@
2		2
3	use strict;	3	#
		4	# This file is part of Deliantra, the Roguelike Realtime MMORPG.
		5	#
		6	# Copyright (©) 2007,2008,2009,2010,2011 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
		7	#
		8	# Deliantra is free software: you can redistribute it and/or modify it under
		9	# the terms of the Affero GNU General Public License as published by the
		10	# Free Software Foundation, either version 3 of the License, or (at your
		11	# option) any later version.
		12	#
		13	# This program is distributed in the hope that it will be useful,
		14	# but WITHOUT ANY WARRANTY; without even the implied warranty of
		15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
		16	# GNU General Public License for more details.
		17	#
		18	# You should have received a copy of the Affero GNU General Public License
		19	# and the GNU General Public License along with this program. If not, see
		20	# <http://www.gnu.org/licenses/>.
		21	#
		22	# The authors can be reached via e-mail to <support@deliantra.net>
		23	#
		24
		25	use common::sense;
4		26
5	my $prefix = "@prefix@";	27	my $prefix = "@prefix@";
6	my $exec_prefix = "@exec_prefix@";	28	my $exec_prefix = "@exec_prefix@";
7	my $datarootdir = "@datarootdir@";	29	my $datarootdir = "@datarootdir@";
8	my $DATADIR = "@datadir@/@PACKAGE@";	30	my $DATADIR = "@datadir@/@PACKAGE@";
9		31
10	my $CONVERT = "@CONVERT@";	32	my $CONVERT = "@CONVERT@";
11	#my $IDENTIFY = "@IDENTIFY@";	33	my $IDENTIFY = "@IDENTIFY@";
12	my $OPTIPNG = "@OPTIPNG@";	34	my $OPTIPNG = "@OPTIPNG@";
13	my $RSYNC = "@RSYNC@";	35	my $RSYNC = "@RSYNC@";
14	my $PNGNQ = "@PNGNQ@";	36	my $PNGNQ = "@PNGNQ@";
15		37
16	use Getopt::Long;	38	use Getopt::Long;
17	use Coro::Event;	39	use File::Temp;
		40	use POSIX ();
		41	use Carp;
		42
		43	use YAML::XS ();
		44	use Digest::MD5 ();
		45	use Storable ();
		46	use JSON::XS ();
		47	use IO::AIO ();
		48	use Compress::LZF ();
		49
18	use AnyEvent;	50	use AnyEvent;
19	use IO::AIO ();	51	use Coro 5.12;
20	use File::Temp;
21	use Crossfire;
22	use Coro;	52	use Coro::EV;
23	use Coro::AIO;	53	use Coro::AIO;
24	use POSIX ();	54	use Coro::Util;
25	use Digest::MD5;	55	use Coro::Channel;
		56	use Coro::AnyEvent;
26	use Coro::Storable; $Storable::canonical = 1;	57	use Coro::Storable; $Storable::canonical = 1;
		58
		59	use Deliantra;
		60
		61	$SIG{QUIT} = sub { Carp::cluck "QUIT" };
27		62
28	sub usage {	63	sub usage {
29	warn <<EOF;	64	warn <<EOF;
30	Usage: cfutil [-v] [-q] [--force] [--cache]	65	Usage: cfutil [-v] [-q] [--force] [--cache]
31	[--install-arch path]	66	[--install-arch path]
42	my $VERBOSE = 1;	77	my $VERBOSE = 1;
43	my $CACHE = 0;	78	my $CACHE = 0;
44	my $FORCE;	79	my $FORCE;
45	my $TMPDIR = "/tmp/cfutil$$~";	80	my $TMPDIR = "/tmp/cfutil$$~";
46	my $TMPFILE = "aaaa0";	81	my $TMPFILE = "aaaa0";
		82	my @COMMIT;
47		83
48	our %COLOR = (	84	our %COLOR = (
		85	# original cf colours
49	black => 0,	86	black => 0,
50	white => 1,	87	white => 1,
51	navy => 2,	88	navy => 2, # "dark blue"
52	red => 3,	89	red => 3,
53	orange => 4,	90	orange => 4,
54	blue => 5,	91	blue => 5, # "light blue"
55	darkorange => 6,	92	darkorange => 6,
56	green => 7,	93	green => 7,
57	lightgreen => 8,	94	lightgreen => 8,
58	grey => 9,	95	grey => 9,
		96	brown => 10, # "yellow"
		97	gold => 11, # "light yellow"
		98	tan => 12, # yellowish gray
		99
		100	# new for deliantra
59	brown => 10,	101	none => 13,
		102
		103	# compatibility to existing archetypes
		104	lightblue => 5,
60	gold => 11,	105	gray => 9,
		106	yellow => 11,
61	tan => 12,	107	khaki => 12,
62	);	108	);
63		109
64	END { system "rm", "-rf", $TMPDIR }	110	END { system "rm", "-rf", $TMPDIR }
65		111
66	Event->signal (signal => "INT", cb => sub { exit 1 });	112	my $s_INT = AE::signal INT => sub { exit 1 };
67	Event->signal (signal => "TERM", cb => sub { exit 1 });	113	my $s_TERM = AE::signal TERM => sub { exit 1 };
		114
		115	our %hash;
		116
		117	# here we could try to avoid collisions and reduce chksum size further
		118	sub make_hash($\$\$;$) {
		119	my ($id, $dataref, $hashref, $clen) = @_;
		120
		121	my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen \|\| 5;
		122
		123	if (exists $hash{$hash}) {
		124	# hash collision, but some files are simply identical
		125	if (${$hash{$hash}[1]} ne $$dataref) {
		126	warn "ERROR: hash collision $hash{$hash}[0] vs. $id (increase the default \$clen in make_hash?)\n";
		127	exit 1;
		128	} else {
		129	print "$hash{$hash}[0] and $id are identical (which is fine).\n" if $VERBOSE >= 3;
		130	}
		131	}
		132	$hash{$hash} = [$id, $dataref, $hashref];
		133
		134	$$hashref = $hash;
		135	}
		136
		137	sub optipng($) {
		138	system $OPTIPNG, "-o5", "-i0", "-q", $_[0];
		139	die "$_[0] has zero size, aborting." unless -s $_[0];
		140	}
68		141
69	mkdir $TMPDIR, 0700	142	mkdir $TMPDIR, 0700
70	or die "$TMPDIR: $!";	143	or die "$TMPDIR: $!";
71		144
72	sub fork_sub(&) {	145	sub fork_exec(&) {
73	my ($cb) = @_;	146	my ($cb) = @_;
74		147
75	if (my $pid = fork) {	148	if (my $pid = fork) {
76	my $current = $Coro::current;	149	my $current = $Coro::current;
77	my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });	150	my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
…		…
82	warn $@;	155	warn $@;
83	POSIX::_exit 1;	156	POSIX::_exit 1;
84	}	157	}
85	}	158	}
86		159
		160	sub imgsize($) {
		161	open my $fh, "-\|", $IDENTIFY, qw(-ping -format %w,%h --), $_[0]
		162	or die "$IDENTIFY: $!";
		163
		164	Coro::AnyEvent::readable $fh;
		165
		166	my ($w, $h) = split /,/, <$fh>;
		167
		168	($w+0, $h+0)
		169	}
		170
		171	# make $dst from $src, if not uptodate, by calling $how
		172	sub make_file($$$) {
		173	my ($src, $dst, $how) = @_;
		174
		175	my $t = (aio_stat $dst) ? -1 : (stat _)[9];
		176
		177	for (ref $src ? @$src : $src) {
		178	aio_stat $_
		179	and die "$_: $!";
		180
		181	if ((stat _)[9] > $t) {
		182	# outdated, redo
		183	$how->();
		184	last;
		185	}
		186	}
		187	}
		188
87	sub inst_maps($) {	189	sub inst_maps($) {
88	my (undef, $path) = @_;	190	my (undef, $path) = @_;
89		191
90	print "\nInstalling '$path' to '$DATADIR/maps'\n\n";	192	print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
91		193
92	if (!-f "$path/regions") {	194	if (!-f "$path/regions") {
93	warn "'$path' does not look like a maps directory ('regions' file is missing).\n";	195	warn "ERROR: '$path' does not look like a maps directory ('regions' file is missing).\n";
94	exit 1 unless $FORCE;	196	exit 1 unless $FORCE;
95	}	197	}
96		198
97	system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded"	199	system $RSYNC, "-av", "--chmod=u=rwX,go=rX",
		200	"$path/.", "$DATADIR/maps/.",
		201	"--exclude", "CVS", "--exclude", "/world-precomposed",
		202	"--delete", "--delete-excluded"
98	and die "map installation failed.\n";	203	and die "map installation failed.\n";
99		204
100	print "maps installed successfully.\n";	205	print "maps installed successfully.\n";
101	}	206	}
102		207
…		…
105	our %FACEINFO;	210	our %FACEINFO;
106	our %RESOURCE;	211	our %RESOURCE;
107	our @ARC;	212	our @ARC;
108	our %ARC;	213	our %ARC;
109	our $TRS;	214	our $TRS;
		215	our %PNG;
110	our $NFILE;	216	our $NFILE;
111	our $PATH;	217	our $PATH;
112		218
113	our $QUANTIZE = "+dither -colorspace RGB -colors 256";	219	our $QUANTIZE = "+dither -colorspace RGB -colors 256";
114		220
115	our (@png, @trs, @arc, @res); # files we are interested in	221	our $c_arc = new Coro::Channel;
		222	our $c_any = new Coro::Channel;
116		223
		224	our @c_png;
		225
117	sub commit_png($$$) {	226	sub commit_png($$$$) {
118	my ($name, $data, $T) = @_;	227	my ($stem, $name, $data, $T) = @_;
119		228
		229	$FACEINFO{$name}{"stem"} = substr $stem, 1 + length $PATH;
120	$FACEINFO{$name}{"data$T"} = $data;	230	$FACEINFO{$name}{"data$T"} = $data;
121	}	231	}
122		232
123	sub process_png {	233	sub process_png {
124	while (@png) {	234	while (@c_png) {
125	my ($path, $delete) = @{pop @png};	235	my ($path, $delete) = @{pop @c_png};
126		236
127	my $png;	237	my $png;
128	aio_lstat $path;	238	aio_lstat $path;
129	my ($size, $mtime) = (stat _)[7,9];	239	my ($size, $mtime) = (stat _)[7,9];
130		240
131	if (0 > aio_load $path, $png) {	241	if (0 > aio_load $path, $png) {
132	warn "$path: $!, skipping.\n";	242	warn "ERROR: $path: $!, skipping.\n";
133	next;	243	next;
134	}	244	}
135		245
136	my $stem = $path;	246	my $stem = $path;
137	my $T;	247	my $T;
…		…
139	if ($stem =~ s/\.32x32\.png~?$//) {	249	if ($stem =~ s/\.32x32\.png~?$//) {
140	$T = 32;	250	$T = 32;
141	} elsif ($stem =~ s/\.64x64\.png~?$//) {	251	} elsif ($stem =~ s/\.64x64\.png~?$//) {
142	$T = 64;	252	$T = 64;
143	} else {	253	} else {
144	warn "$path: weird filename, skipping.\n";	254	warn "ERROR: $path: weird filename, skipping.\n";
145	next;	255	next;
146	}	256	}
147		257
148	# quickly extract width and height of the (necessarily PNG) image	258	# quickly extract width and height of the (necessarily PNG) image
149	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {	259	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
150	warn "$path: not a recognized png file, skipping.\n";	260	warn "ERROR: $path: not a recognized png file, skipping.\n";
151	next;	261	next;
152	}	262	}
153		263
154	my ($w, $h) = unpack "NN", $1;	264	my ($w, $h) = unpack "NN", $1;
155		265
156	if ($w < $T \|\| $h < $T) {	266	if ($w < $T \|\| $h < $T) {
157	warn "$path: too small ($w $h), skipping.\n";	267	warn "ERROR: $path: too small ($w $h), skipping.\n";
158	next;	268	next;
159	}	269	}
160		270
161	if ($w % $T \|\| $h % $T) {	271	if ($w % $T \|\| $h % $T) {
162	warn "$path: weird png size ($w $h), skipping.\n";	272	warn "ERROR: $path: weird png size ($w $h), skipping.\n";
163	next;	273	next;
164	}	274	}
		275
		276	(my $base = $stem) =~ s/^.*\///;
		277
		278	my $fi = $FACEINFO{$base};
		279	unless ($fi) {
		280	#warn "$path: <$base> not referenced by any archetype, skipping.\n";
		281	#next;
		282	}
		283
		284	my $arc = $fi->{arc} \|\| { };
165		285
166	unless ($path =~ /~$/) {	286	unless ($path =~ /~$/) {
167	# possibly enlarge	287	# possibly enlarge
168	if (0 > aio_stat "$stem.64x64.png") {	288	if (0 > aio_stat "$stem.64x64.png") {
169	my $other = "$stem.64x64.png~";	289	my $other = "$stem.64x64.png~";
170		290
171	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	291	make_file $path, $other, sub {
172	my $wrap = 0; # for the time being
173	fork_sub {	292	fork_exec {
		293	my $CROP;
		294	my $SRC = "png:\Q$path\E";
		295
		296	my $is_floor = $arc->{is_floor};
		297	my $is_wall = 0;
		298
		299	my ($wall_pfx, $wall_dir, $wall_sfx);
		300
		301	if (
		302	!$is_floor
		303	&& !$arc->{alive}
		304	&& $arc->{move_block} eq "all"
		305	&& $path =~ /^(._)([0-9A-F])(\.x11.\.png)$/
		306	) {
		307	($wall_pfx, $wall_dir, $wall_sfx) = ($1, hex $2, $3);
		308
		309	unless (grep { !-e sprintf "%s%X%s", $wall_pfx, $_, $wall_sfx } 0..15) {
		310	$is_wall = 1;
		311	}
		312	}
		313
		314	if ($is_wall \|\| $is_floor) {
		315	# add a 4px border and add other images around it
		316	$CROP = "-shave 8x8 +repage";
		317
		318	$w += 8;
		319	$h += 8;
		320
		321	$SRC = "-size ${w}x${h} xc:transparent";
		322	$SRC .= " png:\Q$path\E -geometry +4+4 -composite";
		323
		324	# 8 surrounding images
		325	for (
		326	# x y b r0 r1
		327	[-1, -1, 0, 6],
		328	[ 0, -1, 1, 10, 14],
		329	[+1, -1, 0, 12],
		330
		331	[-1, 0, 8, 5, 7],
		332	#
		333	[+1, 0, 2, 5, 13],
		334
		335	[-1, +1, 0, 3],
		336	[ 0, +1, 4, 10, 11],
		337	[+1, +1, 0, 9],
		338	) {
		339	my ($x, $y, $d, $r0, $r1) = @$_;
		340
		341	my $tile = $is_floor ? $path
		342	: $is_wall ? sprintf "%s%X%s", $wall_pfx, ($wall_dir & $d) ? $r1 : $r0, $wall_sfx
		343	: die;
		344
		345	$SRC .= sprintf " png:%s -geometry %+d%+d -composite",
		346	"\Q$tile",
		347	$x * ($w - 8) + 4,
		348	$y * ($h - 8) + 4;
		349	}
		350	}
		351
174	system "convert png:\Q$path\E -depth 8 rgba:-"	352	system "convert -depth 8 $SRC rgba:-"
175	. "\| $exec_prefix/bin/cfhq2xa $w $h $wrap"	353	. "\| $exec_prefix/bin/cfhq2xa $w $h 0"
176	. "\| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $QUANTIZE -quality 00 png32:\Q$other\E~"	354	. "\| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $CROP $QUANTIZE -quality 00 png32:\Q$other\E~"
177	and die "convert/hq2xa pipeline error: status $? ($!)";	355	and die "convert/cfhq2xa pipeline error: status $? ($!)";
178	system $OPTIPNG, "-i0", "-q", "$other~";	356	optipng "$other~";
179	die "$other~ has zero size, aborting." unless -s "$other~";
180	rename "$other~", $other;	357	rename "$other~", $other;
181	};	358	};
182	}	359	};
183		360
184	push @png, [$other, !$CACHE];	361	push @c_png, [$other, !$CACHE];
185	}	362	}
186		363
187	# possibly scale down	364	# possibly scale down
188	if (0 > aio_stat "$stem.32x32.png") {	365	if (0 > aio_stat "$stem.32x32.png") {
189	my $other = "$stem.32x32.png~";	366	my $other = "$stem.32x32.png~";
190		367
191	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	368	make_file $path, $other, sub {
192	fork_sub {	369	fork_exec {
193	system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";	370	system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
194	system $OPTIPNG, "-i0", "-q", "$other~";	371	optipng "$other~";
195		372
196	# reduce smoothfaces >10000 bytes	373	# reduce smoothfaces >10000 bytes
		374	# obsolete, no longer required
197	if ($stem =~ /_S\./ && (-s "$other~") > 10000) {	375	if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
198	my $ncolor = 256;	376	my $ncolor = 256;
199	while () {	377	while () {
200	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";	378	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
201	system $OPTIPNG, "-i0", "-q", "$other~~";	379	optipng "$other~~";
202	last if 10000 > -s "$other~~";	380	last if 10000 > -s "$other~~";
203	$ncolor = int $ncolor * 0.9;	381	$ncolor = int $ncolor * 0.9;
204	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";	382	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
205	}	383	}
206		384
…		…
211	}	389	}
212		390
213	die "$other~ has zero size, aborting." unless -s "$other~";	391	die "$other~ has zero size, aborting." unless -s "$other~";
214	rename "$other~", $other;	392	rename "$other~", $other;
215	};	393	};
216	}	394	};
217		395
218	#warn "scaled down $path to $other\n";#d#	396	#warn "scaled down $path to $other\n";#d#
219	push @png, [$other, !$CACHE];	397	push @c_png, [$other, !$CACHE];
220	}	398	}
221	}	399	}
222		400
223	(my $face = $stem) =~ s/^.*\///;	401	(my $face = $stem) =~ s/^.*\///;
		402
		403	for (@{ $fi->{derive} }) {
		404	my ($dir, $type) = @$_;
		405
		406	my $geom = "${T}x${T}";
		407	my $dpath = "$dir/$type:$face.$geom.png~";
		408
		409	if ($type eq "buildmaterial") {
		410	my $ov = "$PATH/mapbuilding/buildmaterial.png";
		411	make_file [$path, $ov], $dpath, sub {
		412	fork_exec {
		413	system "$CONVERT -size 64x64 xc:transparent \$ \Q$path\E -geometry 52x52+6+6 \$ -composite \Q$ov\E -composite -geometry $geom png:\Q$dpath\E~";
		414	optipng "$dpath~";
		415	rename "$dpath~", $dpath;
		416	};
		417	};
		418	} elsif ($type eq "buildmaterial-box") {
		419	my $ov = "$PATH/mapbuilding/buildmaterial-box.png";
		420	make_file [$path, $ov], $dpath, sub {
		421	fork_exec {
		422	system "$CONVERT \Q$ov\E "
		423	. "\\( \Q$path\E -trim -geometry 34x31\\> "
		424	. "-gravity center -background transparent -extent 37x34 +gravity "
		425	. "-geometry +22+6 \\) -composite "
		426	. "-geometry $geom png:\Q$dpath\E~";
		427	optipng "$dpath~";
		428	rename "$dpath~", $dpath;
		429	};
		430	};
		431	} elsif ($type eq "buildmaterial-sbox") {
		432	my $ov = "$PATH/mapbuilding/buildmaterial-sbox.png";
		433	make_file [$path, $ov], $dpath, sub {
		434	fork_exec {
		435	system "$CONVERT \Q$ov\E "
		436	. "\\( \Q$path\E -trim -geometry 16x24\\> "
		437	. "-gravity center -background transparent -extent 18x26 +gravity "
		438	. "-geometry +26+16 \\) -composite "
		439	. "-geometry $geom png:\Q$dpath\E~";
		440	optipng "$dpath~";
		441	rename "$dpath~", $dpath;
		442	};
		443	};
		444	} else {
		445	warn "ERROR: facename $type:$face contains unsupported derivation type.\n";
		446	}
		447
		448	aio_load $dpath, my $png;
		449	IO::AIO::aio_unlink $dpath unless $CACHE;
		450	commit_png "$dir/$type:$face", "$type:$face", $png, $T;
		451	}
224		452
225	# split all bigfaces, but avoid smoothfaces (*_S)	453	# split all bigfaces, but avoid smoothfaces (*_S)
226	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {	454	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {
227	# split	455	# split
228	my @tile;	456	my @tile;
…		…
233	push @tile, [$x, $y, $file, (stat _)[9]];	461	push @tile, [$x, $y, $file, (stat _)[9]];
234	}	462	}
235	}	463	}
236		464
237	my $mtime = (lstat $path)[9];	465	my $mtime = (lstat $path)[9];
238	my @todo = grep { $_->[3] <= $mtime } @tile;	466	my @todo = grep { $_->[3] < $mtime } @tile;
239	if (@todo) {	467	if (@todo) {
240	fork_sub {	468	fork_exec {
241	open my $convert, "\|-", $CONVERT,	469	open my $convert, "\|-", $CONVERT,
242	"png:-",	470	"png:-",
243	(map {	471	(map {
244	(	472	(
245	"(",	473	"(",
…		…
258	print $convert $png;	486	print $convert $png;
259	close $convert;	487	close $convert;
260		488
261	# pass 2, optimise, and rename	489	# pass 2, optimise, and rename
262	for (@todo) {	490	for (@todo) {
263	system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";	491	optipng "$_->[2]~";
264	die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
265	rename "$_->[2]~", $_->[2];	492	rename "$_->[2]~", $_->[2];
266	}	493	}
267	};	494	};
268	}	495	}
269		496
…		…
273		500
274	if (0 > aio_load $file, $tile) {	501	if (0 > aio_load $file, $tile) {
275	die "$path: unable to read tile +$x+$y, aborting.\n";	502	die "$path: unable to read tile +$x+$y, aborting.\n";
276	}	503	}
277	IO::AIO::aio_unlink $file unless $CACHE;	504	IO::AIO::aio_unlink $file unless $CACHE;
278	commit_png $x\|$y ? "$face+$x+$y" : $face, $tile, $T;	505	commit_png $stem, $x\|$y ? "$face+$x+$y" : $face, $tile, $T;
279	}	506	}
280	} else {	507	} else {
281	# use as-is (either small, use smooth)	508	# use as-is (either small, use smooth)
282	commit_png $face, $png, $T;	509	commit_png $stem, $face, $png, $T;
283	}	510	}
284		511
285	aio_unlink $path if $delete;	512	IO::AIO::aio_unlink $path if $delete;
		513	}
		514	}
		515
		516	sub process_faceinfo {
		517	my ($dir, $file) = @_;
		518	my $path = "$dir/$file";
		519
		520	my $data;
		521	if (0 > aio_load $path, $data) {
		522	warn "ERROR: $path: $!, skipping.\n";
		523	return;
		524	}
		525
		526	for (split /\n/, $data) {
		527	chomp;
		528	my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
		529	# bg not used except for text clients
		530
		531	utf8::decode $glyph;
		532	$glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag
		533	$glyph =~ s/^"(.+)"$/$1/; # allow for ""-style quoting
		534
		535	$fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet
		536
		537	(my $fgi = $COLOR{$fg})
		538	// warn "ERROR: $path: $face specifies unknown foreground colour '$fg'.\n";
		539	(my $bgi = $COLOR{$bg})
		540	// warn "ERROR: $path: $face specifies unknown background colour '$bg'.\n";
		541
		542	my $fi = $FACEINFO{$face} \|\|= { };
		543	$fi->{visibility} = $visibility * 1;
		544	$fi->{magicmap} = $fgi; # foreground colour becomes magicmap
		545
		546	$glyph .= " " if 2 > length $glyph; # TODO kanji
		547	die "glyph $face too long" if 2 < length $glyph;
		548
		549	$fi->{glyph} = "";
		550	for (split //, $glyph) {
		551	utf8::encode $_;
		552	$fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
		553	}
286	}	554	}
287	}	555	}
288		556
289	sub process_arc {	557	sub process_arc {
290	while (@arc) {	558	while (my ($dir, $file) = @{ $c_arc->get }) {
291	my ($dir, $file) = @{pop @arc};
292
293	my $arc;	559	my $arc;
294	aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/	560	aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
295		561
296	my $arc = read_arch "$dir/$file";	562	my $arc = read_arch "$dir/$file";
297	for my $o (values %$arc) {	563	for my $o (values %$arc) {
298	push @ARC, $o;	564	push @ARC, $o;
299	for (my $m = $o; $m; $m = $m->{more}) {	565	for (my $m = $o; $m; $m = $m->{more}) {
300	$ARC{$m->{_name}} = $m;	566	$ARC{$m->{_name}} = $m;
301	}	567	}
302		568
303	$o->{editor_folder} = $dir;	569	$o->{editor_folder} \|\|= "\x00$dir"; # horrible kludge
304
305	my $visibility = delete $o->{visibility};
306	my $magicmap = delete $o->{magicmap};
307		570
308	# find upper left corner :/	571	# find upper left corner :/
309	# omg, this is sooo broken	572	# omg, this is sooo broken
310	my ($dx, $dy);	573	my ($dx, $dy);
311	for (my $o = $o; $o; $o = $o->{more}) {	574	for (my $o = $o; $o; $o = $o->{more}) {
…		…
318	my $y = $o->{y} - $dy;	581	my $y = $o->{y} - $dy;
319		582
320	my $ext = $x\|$y ? "+$x+$y" : "";	583	my $ext = $x\|$y ? "+$x+$y" : "";
321		584
322	$o->{face} .= $ext unless /^blank.x11$\|^empty.x11$/ \|\| !$o->{face};	585	$o->{face} .= $ext unless /^blank.x11$\|^empty.x11$/ \|\| !$o->{face};
323
324	$visibility = delete $o->{visibility} if exists $o->{visibility};
325	$magicmap = delete $o->{magicmap} if exists $o->{magicmap};
326		586
327	my $anim = delete $o->{anim};	587	my $anim = delete $o->{anim};
328		588
329	if ($anim) {	589	if ($anim) {
330	# possibly add $ext to the animation name to avoid	590	# possibly add $ext to the animation name to avoid
…		…
348	facings => $facings,	608	facings => $facings,
349	frames => \@frames,	609	frames => \@frames,
350	};	610	};
351	}	611	}
352		612
353	for my $face ($o->{face} \|\| (), @{$anim \|\| []}) {	613	for ($o->{face} \|\| (), @{$anim \|\| []}) {
		614	next if /^facings\s/;
		615
		616	my $face = $_;
		617	$face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
		618
		619	# handle derived faces
		620	if ($face =~ /^([^:]+):(.*)/) {
		621	my ($type, $base) = ($1, $2);
		622	push @{ $FACEINFO{$base}{derive} }, [$dir, $type];
		623	}
		624
		625	$FACEINFO{$face}{arc} = $o;
		626
354	next if $face =~ /^facings\s\|^blank.x11$\|^empty.x11$/;	627	next if $face =~ /^blank.x11$\|^empty.x11$/;
355
356	my $info = $FACEINFO{$face} \|\|= {};
357
358	$info->{visibility} = $visibility if defined $visibility;
359	$info->{magicmap} = $magicmap if defined $magicmap;
360	}	628	}
361		629
362	if (my $smooth = delete $o->{smoothface}) {	630	if (my $smooth = delete $o->{smoothface}) {
363	my %kv =split /\s+/, $smooth;	631	my %kv = split /\s+/, $smooth;
364	my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support	632	my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
365	while (my ($face, $smooth) = each %kv) {	633	while (my ($face, $smooth) = each %kv) {
		634	$FACEINFO{$smooth}{arc} = $o;
		635
366	$FACEINFO{$face}{smooth} = $smooth;	636	$FACEINFO{$face}{smooth} = $smooth;
367	$FACEINFO{$face}{smoothlevel} = $level;	637	$FACEINFO{$face}{smoothlevel} = $level;
368	}	638	}
369	}	639	}
370	}	640	}
371	}	641	}
372	}	642	}
373	}	643	}
374		644
375	sub process_trs {	645	sub process_trs {
376	while (@trs) {
377	my ($dir, $file) = @{pop @trs};	646	my ($dir, $file) = @_;
378	my $path = "$dir/$file";	647	my $path = "$dir/$file";
379		648
380	my $trs;	649	my $trs;
381	if (0 > aio_load $path, $trs) {	650	if (0 > aio_load $path, $trs) {
382	warn "$path: $!, skipping.\n";	651	warn "ERROR: $path: $!, skipping.\n";
		652	return;
		653	}
		654
		655	$TRS .= $trs;
		656	}
		657
		658	my %FILECACHE;
		659
		660	sub load_cached($;$) {
		661	unless (exists $FILECACHE{$_[0]}) {
		662	my $data;
		663	if (0 < aio_load $_[0], $data) {
		664	if ($_[1]) {
		665	$data = eval { $_[1]->($data) };
		666	warn "ERROR: $_[0]: $@" if $@;
383	next;	667	}
		668	}
		669
		670	$FILECACHE{$_[0]} = $data;
		671	}
		672
		673	$FILECACHE{$_[0]}
		674	}
		675
		676	# convert an image and a palette to some indexed 2d-matrix structure
		677	sub process_plt {
		678	my ($base, $plt) = @_;
		679
		680	my ($w, $h) = imgsize "$base.png";
		681
		682	$w * $h
		683	or die "$base.png: unable to identify correct size\n";
		684
		685	my @plt;
		686	my %map;
		687
		688	for (split /\n/, $plt) {
		689	next unless /\S/;
		690	next if /^\s*#/;
		691
		692	/^([0-9a-fA-F]{3,6})\s(.?)\s*$/
		693	or die "unparseable palette entry for $base.plt: $_";
		694
		695	my ($rgb, $name) = ($1, $2);
		696
		697	$rgb =~ s/^(.)(.)(.)$/$1$1$2$2$3$3/;
		698
		699	$map{pack "H*", $rgb} = chr @plt;
		700	push @plt, $name;
		701	}
		702
		703	make_file ["$base.plt", "$base.png"], "$base.tbl~", sub {
		704	warn "building $base\n" if $VERBOSE >= 3;
		705
		706	fork_exec {
		707	open my $png, "-\|", $CONVERT, qw(-depth 8 --), "$base.png", "rgb:"
		708	or die "$base.png: $!";
		709
		710	local $/;
		711	$png = <$png>;
		712
		713	$w * $h * 3 == length $png
		714	or die "$base.png: failed to read enough data from file\n";
		715
		716	$png =~ s/(...)/$map{$1}/ge;
		717
		718	$w * $h == length $png
		719	or die "$base.png: failed to map all data - wrong palette?\n";
		720
		721	{
		722	open my $fh, ">:raw", "$base.tbl~~"
		723	or die "$base.tbl~~: $!";
		724	syswrite $fh, $png;
		725	}
		726
		727	rename "$base.tbl~~", "$base.tbl~";
384	}	728	};
		729	};
385		730
386	$TRS .= $trs;	731	0 <= aio_load "$base.tbl~", my $tbl
		732	or die "$base.tbl~: $!";
		733
		734	IO::AIO::aio_unlink "$base.tbl~" unless $CACHE;
		735
		736	Compress::LZF::compress nfreeze {
		737	w => $w,
		738	h => $h,
		739	plt => \@plt,
		740	tbl => $tbl,
387	}	741	}
388	}	742	}
389		743
390	sub process_res {	744	sub process_res {
391	while (@res) {	745	my ($dir, $file, $type) = @_;
392	my ($dir, $file) = @{pop @res};
393		746
394	my $data;
395	aio_load "$dir/$file", $data;	747	0 <= aio_load "$dir/$file", my $data
		748	or die "$dir/$file: $!";
396		749
397	my $copyright;	750	my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
398	aio_load "$dir/copyright", $copyright;
399		751
		752	utf8::decode $dir;
		753	utf8::decode $file;
		754
		755	# a meta file for resources is now mandatory
		756	unless (exists $meta->{$file}) {
		757	warn "skipping $dir/$file\n" if $VERBOSE >= 3;
		758	return;
		759	}
		760
		761	$meta = {
		762	%{ $meta->{"" } \|\| {} },
		763	%{ $meta->{$file} \|\| {} },
		764	};
		765
		766	if ($meta->{license} =~ s/^#//) {
		767	$meta->{license} = ({
		768	"pd" => "Public Domain",
		769	"gpl" => "GNU General Public License, version 3.0 or any later",
		770	"cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
		771	"cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
		772	"cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
		773	"cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
		774	})->{$meta->{license}}
		775	\|\| warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
		776	}
		777
		778	if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
		779	($meta->{author} = $1) =~ s/_/ /g;
		780	}
		781
400	$file =~ s/\.res$//;	782	$file =~ s/\.res$//;
401	$file =~ /\.([^.]+)$/	783	$file =~ s/\.(ogg\|wav\|jpg\|png)$//;
402	or next;
403		784
404	my $type = $1;	785	if ($file =~ s/\.plt$//) {
		786	$data = process_plt "$dir/$file", $data;
		787	} elsif (my $filter = $meta->{cfutil_filter}) {
		788	if ($filter eq "yaml2json") {
		789	$data = JSON::XS::encode_json YAML::XS::Load $data;
		790	} elsif ($filter eq "json2json") {
		791	$data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
		792	} elsif ($filter eq "perl2json") {
		793	$data = eval $data; die if $@;
		794	$data = JSON::XS::encode_json $data;
		795	} else {
		796	warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
		797	}
		798	}
405		799
406	substr $dir, 0, 1 + length $PATH, "";	800	substr $dir, 0, 1 + length $PATH, "";
407		801
408	$RESOURCE{"$dir/$file"} = {	802	$RESOURCE{"$dir/$file"} = {
409	type => $1,	803	type => (exists $meta->{type} ? delete $meta->{type} : $type),
410	copyright => $copyright,
411	data => $data,	804	data => $data,
412	chksum => Digest::MD5::md5 $data,	805	%$meta ? (meta => $meta) : (),
413	};	806	};
		807	}
		808
		809	sub process_any {
		810	while (my ($func, @args) = @{ $c_any->get }) {
		811	$func->(@args);
414	}	812	}
415	}	813	}
416		814
417	sub find_files;	815	sub find_files;
418	sub find_files {	816	sub find_files {
419	my ($path) = @_;	817	my ($path) = @_;
420		818
		819	my $grp = IO::AIO::aio_group;
		820
		821	my $scandir; $scandir = sub {
		822	my ($path) = @_;
		823
421	IO::AIO::aioreq_pri 4;	824	IO::AIO::aioreq_pri 4;
422	IO::AIO::aio_scandir $path, 4, sub {	825	add $grp IO::AIO::aio_scandir $path, 4, sub {
423	my ($dirs, $nondirs) = @_;	826	my ($dirs, $nondirs) = @_;
424		827
425	find_files "$path/$_"	828	$scandir->("$path/$_")
426	for grep $_ !~ /^(?:CVS\|dev)$/, @$dirs;	829	for grep $_ !~ /^(?:CVS\|dev\|\..*)$/, @$dirs;
427		830
		831	my $dir = $path;
		832	substr $dir, 0, 1 + length $PATH, "";
		833
428	for my $file (@$nondirs) {	834	for my $file (@$nondirs) {
		835	if ($dir =~ /^music(?:\/\|$)/) {
		836	$c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
		837	if $file =~ /\.(ogg)$/;
		838
		839	} elsif ($dir =~ /^sound(?:\/\|$)/) {
		840	$c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
		841	if $file =~ /\.(wav\|ogg)$/;
		842
		843	} elsif ($dir =~ /^res(?:\/\|$)/) {
		844	if ($file =~ /\.(jpg\|png)$/) {
		845	$c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
		846	} elsif ($file =~ /\.(res)$/) {
		847	$c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
		848	} else {
		849	$c_any->put ([\&process_res, $path, $file, undef]);
		850	}
		851
429	if ($file =~ /\.png$/) {	852	} elsif ($file =~ /\.png$/) {
430	push @png, ["$path/$file", 0];	853	$PNG{$file} = $path;
		854
		855	} elsif ($file =~ /\.faceinfo$/) {
		856	$c_any->put ([\&process_faceinfo, $path, $file]);
		857
431	} elsif ($file =~ /\.trs$/) {	858	} elsif ($file =~ /\.trs$/) {
432	push @trs, [$path, $file];	859	$c_any->put ([\&process_trs, $path, $file]);
		860
433	} elsif ($file =~ /\.arc$/) {	861	} elsif ($file =~ /\.arc$/) {
434	push @arc, [$path, $file];	862	$c_arc->put ([$path, $file]);
435	} elsif ($file =~ /\.(ogg\|res)$/) {	863
436	push @res, [$path, $file];
437	} else {	864	} else {
438	warn "ignoring $path/$file\n" if $VERBOSE >= 3;	865	warn "ignoring $path/$file\n" if $VERBOSE >= 3;
439	}	866	}
		867	}
440	}	868	};
441	};	869	};
		870
		871	$scandir->($path);
		872	aio_wait $grp;
		873	}
		874
		875	sub generate_plurals {
		876	# use Lingua::EN::Inflect ();
		877	# Lingua::EN::Inflect::classical;
		878	# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
		879	# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
		880	#
		881	# for my $a (@ARC) {
		882	# my $name = $a->{name} \|\| $a->{_name};
		883	#
		884	# next unless $a->{name_pl};
		885	# next if $a->{invisible};
		886	# next if $a->{is_floor};
		887	# next if $a->{no_pick};
		888	#
		889	# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
		890	# my $pl = $test =~ /^(?:eq\|p:.)$/
		891	# ? $name
		892	# : Lingua::EN::Inflect::PL $name;
		893	#
		894	# if ($pl ne $a->{name_pl}) {
		895	# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
		896	# }
		897	# }
442	}	898	}
443		899
444	sub inst_arch($) {	900	sub inst_arch($) {
445	my (undef, $path) = @_;	901	my (undef, $path) = @_;
446		902
…		…
455	"Unless you run verbosely, all following warning\n",	911	"Unless you run verbosely, all following warning\n",
456	"or error messages indicate serious problems.\n",	912	"or error messages indicate serious problems.\n",
457	"\n";	913	"\n";
458		914
459	if (!-d "$path/treasures") {	915	if (!-d "$path/treasures") {
460	warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";	916	warn "FATAL: '$path' does not look like an arch directory ('treasures' directory is missing).\n";
461	exit 1 unless $FORCE;	917	exit 1 unless $FORCE;
462	}	918	}
463		919
		920	print "starting file scan, arc, any processing...\n" if $VERBOSE;
		921
		922	my @a_arc = map +(async \&process_arc), 1..2;
		923	my @a_any = map +(async \&process_any), 1..4;
		924
464	find_files $path;	925	find_files $path;
465	IO::AIO::flush;
466		926
467	$_->join for (	927	$c_arc->shutdown;
		928	$c_any->shutdown;
		929
		930	$_->join for @a_arc; # need to parse all archetypes before png processing
		931	print "ended arc processing...\n" if $VERBOSE;
		932
		933	# fill png queue
		934	for (keys %FACEINFO) {
		935	# we only expect source pngs to exist for non-derived
		936	# faces, i.e. no split tiles (+x+x) and no face derivates
		937	# (xxx:)
		938	/^[^:]+\....$/
		939	or next;
		940
		941	my $seen;
		942
		943	if (exists $PNG{"$_.32x32.png"}) {
		944	push @c_png, ["$PNG{\"$_.32x32.png\"}/$_.32x32.png"];
		945	$seen = 1;
		946	}
		947	if (exists $PNG{"$_.64x64.png"}) {
		948	push @c_png, ["$PNG{\"$_.64x64.png\"}/$_.64x64.png"];
		949	$seen = 1;
		950	}
		951
		952	warn "ERROR: $_: face not found, expect problems.\n"
		953	unless $seen;
		954	}
		955
		956	print "starting png processing...\n" if $VERBOSE;
		957
468	# four png crunchers work fine for my 2x smp machine	958	# eight png crunchers work fine for my 4x smp machine
469	(async \&process_png), (async \&process_png), (async \&process_png), (async \&process_png),	959	my @a_png = map +(async \&process_png), 1..8;
470	(async \&process_trs), (async \&process_trs),
471	(async \&process_arc), (async \&process_arc),
472	(async \&process_res), (async \&process_res),
473	);
474		960
		961	$_->join for @a_any;
		962	print "ended any processing...\n" if $VERBOSE;
		963
		964	$_->join for @a_png;
		965	print "ended png processing...\n" if $VERBOSE;
		966
		967	print "scanning done, processing results...\n" if $VERBOSE;
475	{	968	{
476	# remove path prefix from editor_folder	969	# remove path prefix from editor_folder
		970	$_->{editor_folder} =~ /^\x00/
477	substr $_->{editor_folder}, 0, 1 + length $path, ""	971	and substr $_->{editor_folder}, 0, 2 + length $path, ""
478	for values %ARC;	972	for values %ARC;
479		973
		974	print "resolving inheritance tree...\n" if $VERBOSE;
480	# resolve inherit	975	# resolve inherit
481	while () {	976	while () {
482	my $progress;	977	my $progress;
483	my $loop;	978	my $loop;
484		979
485	for my $o (values %ARC) {	980	for my $o (values %ARC) {
486	if (my $other = $o->{inherit}) {	981	for my $other (split /,/, $o->{inherit}) {
487	if (my $s = $ARC{$other}) {	982	if (my $s = $ARC{$other}) {
488	if ($s->{inherit}) {	983	if ($s->{inherit}) {
489	$loop = $s;	984	$loop = $s;
490	} else {	985	} else {
491	delete $o->{inherit};	986	delete $o->{inherit};
…		…
493	delete @s{qw(_name more name name_pl)};	988	delete @s{qw(_name more name name_pl)};
494	%$o = ( %s, %$o );	989	%$o = ( %s, %$o );
495	++$progress;	990	++$progress;
496	}	991	}
497	} else {	992	} else {
498	warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";	993	warn "ERROR: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
499	delete $ARC{$o->{_name}};	994	delete $ARC{$o->{_name}};
500	}	995	}
501	}	996	}
502	}	997	}
503		998
…		…
510	}	1005	}
511		1006
512	# remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit	1007	# remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
513	@ARC = grep $_->{_name} !~ /^(?:type\|class)_/, @ARC;	1008	@ARC = grep $_->{_name} !~ /^(?:type\|class)_/, @ARC;
514		1009
		1010	# fix up archetypes without names, where the archanme doesn't work at all
		1011	for (@ARC) {
		1012	if (!exists $_->{name} and $_->{_name} =~ /_/) {
		1013	for ($_->{name} = $_->{_name}) {
		1014	s/(?:_\d+)+$//;
		1015	s/_[nesw]+$//;
		1016	y/_/ /;
		1017	}
		1018	}
		1019	}
		1020
		1021	#print "generating plurals...\n" if $VERBOSE;
		1022	#generate_plurals;
		1023
		1024	printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
515	open my $fh, ">:utf8", "$DATADIR/archetypes~"	1025	open my $fh, ">:utf8", "$DATADIR/archetypes~"
516	or die "$DATADIR/archetypes~: $!";	1026	or die "$DATADIR/archetypes~: $!";
517	print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];	1027	print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
518	}	1028	}
519		1029
520	{	1030	{
		1031	printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
521	open my $fh, ">:utf8", "$DATADIR/treasures~"	1032	open my $fh, ">:utf8", "$DATADIR/treasures~"
522	or die "$DATADIR/treasures~: $!";	1033	or die "$DATADIR/treasures~: $!";
523	print $fh $TRS;	1034	print $fh $TRS;
524	}	1035	}
525		1036
526	{	1037	{
		1038	print "processing facedata...\n" if $VERBOSE;
527	while (my ($k, $v) = each %FACEINFO) {	1039	while (my ($k, $v) = each %FACEINFO) {
528	length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";	1040	length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
529	length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";	1041	length $v->{data64} or warn "ERROR: face '$k' has no png64 - this will not work.\n";
530		1042
		1043	make_hash $k, $v->{data32}, $v->{hash32};
		1044	make_hash $k, $v->{data64}, $v->{hash64};
		1045
531	length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";	1046	#length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
532	#length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";	1047	#length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
533		1048
534	$v->{chksum32} = Digest::MD5::md5 $v->{data32};	1049	$v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
535	$v->{chksum64} = Digest::MD5::md5 $v->{data64};	1050	$v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
		1051	$v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
536		1052
537	if (my $magicmap = $v->{magicmap}) {	1053	delete @$v{qw(arc stem derive)}; # not used by the server
538	$magicmap =~ y/A-Z_\-/a-z/d;	1054	}
539	$v->{magicmap} = $COLOR{$magicmap};	1055
		1056	print "processing resources...\n" if $VERBOSE;
		1057	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		1058	while (my ($k, $v) = each %RESOURCE) {
		1059
		1060	if ($v->{meta} && $v->{meta}{datadir}) {
		1061	delete $RESOURCE{$k};
		1062
		1063	$k =~ s/^res\/// or die "$k: datadir files must be in res/";
		1064
		1065	printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
		1066	open my $fh, ">:raw", "$DATADIR/$k~"
		1067	or die "$DATADIR/$k~: $!";
		1068	syswrite $fh, $v->{data};
		1069	push @COMMIT, $k;
		1070
		1071	} else {
		1072	if ($v->{type} & 1) {
		1073	# prepend meta info
		1074
		1075	my $meta = $enc->encode ({
		1076	name => $k,
		1077	%{ $v->{meta} \|\| {} },
		1078	});
		1079
		1080	$v->{data} = pack "(w/a)", $meta, $v->{data};
540	}	1081	}
		1082
		1083	make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
541	}	1084	}
		1085	}
		1086
		1087	printf "writing facedata (%d faces, %d anims, %d resources)...\n",
		1088	scalar keys %FACEINFO,
		1089	scalar keys %ANIMINFO,
		1090	scalar keys %RESOURCE
		1091	if $VERBOSE;
542		1092
543	open my $fh, ">:perlio", "$DATADIR/facedata~"	1093	open my $fh, ">:perlio", "$DATADIR/facedata~"
544	or die "$DATADIR/facedata~: $!";	1094	or die "$DATADIR/facedata~: $!";
545		1095
546	print $fh freeze {	1096	print $fh nfreeze {
547	version => 2,	1097	version => 2,
548	faceinfo => \%FACEINFO,	1098	faceinfo => \%FACEINFO,
549	animinfo => \%ANIMINFO,	1099	animinfo => \%ANIMINFO,
550	resource => \%RESOURCE,	1100	resource => \%RESOURCE,
551	};	1101	};
552	}	1102	}
553		1103
		1104	print "committing files...\n" if $VERBOSE;
		1105
554	for (qw(archetypes facedata treasures)) {	1106	for (qw(archetypes facedata treasures), @COMMIT) {
555	chmod 0644, "$DATADIR/$_~";	1107	chmod 0644, "$DATADIR/$_~";
556	rename "$DATADIR/$_~", "$DATADIR/$_"	1108	rename "$DATADIR/$_~", "$DATADIR/$_"
557	or die "$DATADIR/$_: $!";	1109	or die "$DATADIR/$_: $!";
558	}	1110	}
559		1111

Diff Legend

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

Comparing deliantra/server/utils/cfutil.in (file contents): Revision 1.38 by root, Thu Jul 12 08:40:14 2007 UTC vs. Revision 1.116 by root, Sun May 15 20:14:30 2011 UTC

Diff Legend

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.38 by root, Thu Jul 12 08:40:14 2007 UTC vs.
Revision 1.116 by root, Sun May 15 20:14:30 2011 UTC