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

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.104 by root, Sat Oct 16 22:12:18 2010 UTC vs.
Revision 1.125 by root, Mon Nov 19 00:40:55 2012 UTC

…		…
1	#!@PERL@	1	#!@PERL@
2		2
3	#	3	#
4	# This file is part of Deliantra, the Roguelike Realtime MMORPG.	4	# This file is part of Deliantra, the Roguelike Realtime MMORPG.
5	#	5	#
6	# Copyright (©) 2007,2008,2009 Marc Alexander Lehmann / Robin Redeker / the Deliantra team	6	# Copyright (©) 2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
7	#	7	#
8	# Deliantra is free software: you can redistribute it and/or modify it under	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	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	10	# Free Software Foundation, either version 3 of the License, or (at your
11	# option) any later version.	11	# option) any later version.
12	#	12	#
13	# This program is distributed in the hope that it will be useful,	13	# This program is distributed in the hope that it will be useful,
14	# but WITHOUT ANY WARRANTY; without even the implied warranty of	14	# but WITHOUT ANY WARRANTY; without even the implied warranty of
15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the	15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16	# GNU General Public License for more details.	16	# GNU General Public License for more details.
17	#	17	#
18	# You should have received a copy of the Affero GNU General Public License	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	19	# and the GNU General Public License along with this program. If not, see
20	# <http://www.gnu.org/licenses/>.	20	# <http://www.gnu.org/licenses/>.
21	#	21	#
22	# The authors can be reached via e-mail to <support@deliantra.net>	22	# The authors can be reached via e-mail to <support@deliantra.net>
23	#	23	#
24		24
25	use common::sense;	25	use common::sense;
26		26
28	my $exec_prefix = "@exec_prefix@";	28	my $exec_prefix = "@exec_prefix@";
29	my $datarootdir = "@datarootdir@";	29	my $datarootdir = "@datarootdir@";
30	my $DATADIR = "@datadir@/@PACKAGE@";	30	my $DATADIR = "@datadir@/@PACKAGE@";
31		31
32	my $CONVERT = "@CONVERT@";	32	my $CONVERT = "@CONVERT@";
33	#my $IDENTIFY = "@IDENTIFY@";	33	my $IDENTIFY = "@IDENTIFY@";
34	my $OPTIPNG = "@OPTIPNG@";	34	my $OPTIPNG = "@OPTIPNG@";
35	my $RSYNC = "@RSYNC@";	35	my $RSYNC = "@RSYNC@";
36	my $PNGNQ = "@PNGNQ@";	36	my $PNGNQ = "@PNGNQ@";
37		37
38	use Getopt::Long;	38	use Getopt::Long;
39	use File::Temp;	39	use File::Temp;
40	use POSIX ();	40	use POSIX ();
41	use Carp;	41	use Carp;
42		42
43	use Coro::EV;
44	use AnyEvent;
45	use YAML::XS ();	43	use YAML::XS ();
		44	use Digest::MD5 ();
		45	use Storable ();
46	use JSON::XS ();	46	use JSON::XS ();
47	use IO::AIO ();	47	use IO::AIO ();
48	use Digest::MD5 ();	48	use Compress::LZF ();
49		49
		50	use AnyEvent;
50	use Coro 5.12;	51	use Coro 5.12;
		52	use Coro::EV;
51	use Coro::AIO;	53	use Coro::AIO;
52	use Coro::Util;	54	use Coro::Util;
53	use Coro::Channel;	55	use Coro::Channel;
		56	use Coro::AnyEvent;
54	use Coro::Storable; $Storable::canonical = 1;	57	use Coro::Storable; $Storable::canonical = 1;
55		58
56	use Deliantra;	59	use Deliantra;
57		60
58	$SIG{QUIT} = sub { Carp::cluck "QUIT" };	61	$SIG{QUIT} = sub { Carp::cluck "QUIT" };
59
60	sub WRITE_FACEINFO() { 0 }
61		62
62	sub usage {	63	sub usage {
63	warn <<EOF;	64	warn <<EOF;
64	Usage: cfutil [-v] [-q] [--force] [--cache]	65	Usage: cfutil [-v] [-q] [--force] [--cache]
65	[--install-arch path]	66	[--install-arch path]
…		…
106	khaki => 12,	107	khaki => 12,
107	);	108	);
108		109
109	END { system "rm", "-rf", $TMPDIR }	110	END { system "rm", "-rf", $TMPDIR }
110		111
111	my $s_INT = EV::signal INT => sub { exit 1 };	112	my $s_INT = AE::signal INT => sub { exit 1 };
112	my $s_TERM = EV::signal TERM => sub { exit 1 };	113	my $s_TERM = AE::signal TERM => sub { exit 1 };
113		114
114	our %hash;	115	our %hash;
115		116
116	# here we could try to avoid collisions and reduce chksum size further	117	# here we could try to avoid collisions and reduce chksum size further
117	sub make_hash($\$\$;$) {	118	sub make_hash($\$\$;$) {
118	my ($id, $dataref, $hashref, $clen) = @_;	119	my ($id, $dataref, $hashref, $clen) = @_;
119		120
120	my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen \|\| 4;	121	my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen \|\| 5;
121		122
122	if (exists $hash{$hash}) {	123	if (exists $hash{$hash}) {
123	# hash collision, but some files are simply identical	124	# hash collision, but some files are simply identical
124	if (${$hash{$hash}[1]} ne $$dataref) {	125	if (${$hash{$hash}[1]} ne $$dataref) {
125	warn "hash collision $hash{$hash}[0] vs. $id\n";	126	warn "ERROR: hash collision $hash{$hash}[0] vs. $id (increase the default \$clen in make_hash?)\n";
126	exit 1;	127	exit 1;
127	} else {	128	} else {
128	print "$hash{$hash}[0] and $id are identical (which is fine).\n" if $VERBOSE >= 3;	129	print "$hash{$hash}[0] and $id are identical (which is fine).\n" if $VERBOSE >= 3;
129	}	130	}
130	}	131	}
131	$hash{$hash} = [$id, $dataref, $hashref];	132	$hash{$hash} = [$id, $dataref, $hashref];
132		133
133	$$hashref = $hash;	134	$$hashref = $hash;
134	}	135	}
135		136
		137	sub optipng($) {
		138	system $OPTIPNG, "-o5", "-i0", "-q", $_[0];
		139	die "$_[0] has zero size, aborting." unless -s $_[0];
		140	}
		141
136	mkdir $TMPDIR, 0700	142	mkdir $TMPDIR, 0700
137	or die "$TMPDIR: $!";	143	or die "$TMPDIR: $!";
138		144
139	sub fork_sub(&) {	145	sub fork_exec(&) {
140	my ($cb) = @_;	146	my ($cb) = @_;
141		147
142	if (my $pid = fork) {	148	if (my $pid = fork) {
143	my $current = $Coro::current;	149	my $current = $Coro::current;
144	my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });	150	my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
…		…
149	warn $@;	155	warn $@;
150	POSIX::_exit 1;	156	POSIX::_exit 1;
151	}	157	}
152	}	158	}
153		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
154	sub inst_maps($) {	189	sub inst_maps($) {
155	my (undef, $path) = @_;	190	my (undef, $path) = @_;
156		191
157	print "\nInstalling '$path' to '$DATADIR/maps'\n\n";	192	print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
158		193
159	if (!-f "$path/regions") {	194	if (!-f "$path/regions") {
160	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";
161	exit 1 unless $FORCE;	196	exit 1 unless $FORCE;
162	}	197	}
163		198
164	system $RSYNC, "-av", "--chmod=u=rwX,go=rX",	199	system $RSYNC, "-av", "--chmod=u=rwX,go=rX",
165	"$path/.", "$DATADIR/maps/.",	200	"$path/.", "$DATADIR/maps/.",
166	"--exclude", "CVS", "--exclude", "/world-precomposed",	201	"--exclude", "CVS", "--exclude", "/world-precomposed",
167	"--delete", "--delete-excluded"	202	"--delete", "--delete-excluded"
168	and die "map installation failed.\n";	203	and die "map installation failed.\n";
169		204
170	print "maps installed successfully.\n";	205	print "maps installed successfully.\n";
171	}
172
173	{
174	no utf8; # == values are utf-8 encoded
175
176	our @WALL_SUFFIX = qw(⬤ ╹ ╺ ┗ ╻ ┃ ┏ ┣ ╸ ┛ ━ ┻ ┓ ┫ ┳ ╋);
177
178	# used to create crude text glyphs for text-based clients
179	sub autoglyph {
180	my ($stem, $face) = @_;
181
182	if ($stem =~ /^wall\/\|Nimwall/) {
183	return $WALL_SUFFIX[hex $1]
184	if $stem =~ /(_[0-9A-F]).x11/;
185
186	"█"
187
188	} elsif ($stem =~ /^traps\//) {
189	"☠"
190
191	} elsif ($stem =~ /^armour\/shield/) {
192	"Ø"
193
194	} elsif ($stem =~ /^armour\//) {
195	"A"
196
197	} elsif ($stem =~ /^weapon\//) {
198	"†"
199
200	} elsif ($stem =~ /^readable\//) {
201	"✉"
202
203	} elsif ($stem =~ /^river\//) {
204	"~"
205
206	} elsif ($stem =~ /^floor\/\|^ground\/\|Nimfloor/) {
207	"·"
208
209	} elsif ($stem =~ /^spells\//) {
210	"!"
211
212	} elsif ($stem =~ /^exit\//) {
213	"⎆"
214
215	} elsif ($stem =~ /^construct\//) {
216	"⌂"
217
218	} elsif ($stem =~ /^player\//) {
219	"\@"
220
221	} elsif ($stem =~ /^(?:monster\|misc\|class\|connect\|gods\|indoor\|inorganic\|mining\|music\|skills).*\/(.)/) {
222	$1
223
224	} else {
225	substr $stem, 0, 1
226	}
227	}
228	}	206	}
229		207
230	{	208	{
231	our %ANIMINFO;	209	our %ANIMINFO;
232	our %FACEINFO;	210	our %FACEINFO;
233	our %RESOURCE;	211	our %RESOURCE;
234	our @ARC;	212	our @ARC;
235	our %ARC;	213	our %ARC;
236	our $TRS;	214	our $TRS;
		215	our %PNG;
237	our $NFILE;	216	our $NFILE;
238	our $PATH;	217	our $PATH;
239		218
240	our $QUANTIZE = "+dither -colorspace RGB -colors 256";	219	our $QUANTIZE = "+dither -colorspace RGB -colors 256";
241		220
242	our $c_arc = new Coro::Channel;	221	our $c_arc = new Coro::Channel;
243	our $c_any = new Coro::Channel;	222	our $c_any = new Coro::Channel;
244		223
245	our @c_png;	224	our @c_png;
246		225
		226	# texture catalog size, in 64x64 tiles
		227	sub TC_W() { 1024 / 64 }
		228	sub TC_H() { 1024 / 64 }
		229
		230	our @TC = ([]); # texture catalogs
		231
247	sub commit_png($$$$) {	232	sub commit_png($$$$$$) {
248	my ($stem, $name, $data, $T) = @_;	233	my ($stem, $name, $data, $T, $w, $h) = @_;
249		234
250	$FACEINFO{$name}{"stem"} = substr $stem, 1 + length $PATH;	235	$FACEINFO{$name}{stem} = substr $stem, 1 + length $PATH;
251	$FACEINFO{$name}{"data$T"} = $data;	236	$FACEINFO{$name}{"data$T"} = $data;
		237	$FACEINFO{$name}{w} = $w;
		238	$FACEINFO{$name}{h} = $h;
252	}	239	}
253		240
254	sub process_png {	241	sub process_png {
255	while (@c_png) {	242	while (@c_png) {
256	my ($path, $delete) = @{pop @c_png};	243	my ($path, $delete) = @{pop @c_png};
…		…
258	my $png;	245	my $png;
259	aio_lstat $path;	246	aio_lstat $path;
260	my ($size, $mtime) = (stat _)[7,9];	247	my ($size, $mtime) = (stat _)[7,9];
261		248
262	if (0 > aio_load $path, $png) {	249	if (0 > aio_load $path, $png) {
263	warn "$path: $!, skipping.\n";	250	warn "ERROR: $path: $!, skipping.\n";
264	next;	251	next;
265	}	252	}
266		253
267	my $stem = $path;	254	my $stem = $path;
268	my $T;	255	my $T;
…		…
270	if ($stem =~ s/\.32x32\.png~?$//) {	257	if ($stem =~ s/\.32x32\.png~?$//) {
271	$T = 32;	258	$T = 32;
272	} elsif ($stem =~ s/\.64x64\.png~?$//) {	259	} elsif ($stem =~ s/\.64x64\.png~?$//) {
273	$T = 64;	260	$T = 64;
274	} else {	261	} else {
275	warn "$path: weird filename, skipping.\n";	262	warn "ERROR: $path: weird filename, skipping.\n";
276	next;	263	next;
277	}	264	}
278		265
279	# quickly extract width and height of the (necessarily PNG) image	266	# quickly extract width and height of the (necessarily PNG) image
280	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {	267	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
281	warn "$path: not a recognized png file, skipping.\n";	268	warn "ERROR: $path: not a recognized png file, skipping.\n";
282	next;	269	next;
283	}	270	}
284		271
285	my ($w, $h) = unpack "NN", $1;	272	my ($w, $h) = unpack "NN", $1;
286		273
287	if ($w < $T \|\| $h < $T) {	274	if ($w < $T \|\| $h < $T) {
288	warn "$path: too small ($w $h), skipping.\n";	275	warn "ERROR: $path: too small ($w $h), skipping.\n";
289	next;	276	next;
290	}	277	}
291		278
292	if ($w % $T \|\| $h % $T) {	279	if ($w % $T \|\| $h % $T) {
293	warn "$path: weird png size ($w $h), skipping.\n";	280	warn "ERROR: $path: weird png size ($w $h), skipping.\n";
294	next;	281	next;
295	}	282	}
296		283
297	(my $base = $stem) =~ s/^.*\///;	284	(my $base = $stem) =~ s/^.*\///;
298		285
…		…
307	unless ($path =~ /~$/) {	294	unless ($path =~ /~$/) {
308	# possibly enlarge	295	# possibly enlarge
309	if (0 > aio_stat "$stem.64x64.png") {	296	if (0 > aio_stat "$stem.64x64.png") {
310	my $other = "$stem.64x64.png~";	297	my $other = "$stem.64x64.png~";
311		298
312	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	299	make_file $path, $other, sub {
313	fork_sub {	300	fork_exec {
314	my $CROP;	301	my $CROP;
315	my $SRC = "png:\Q$path\E";	302	my $SRC = "png:\Q$path\E";
316		303
317	my $is_floor = $arc->{is_floor};	304	my $is_floor = $arc->{is_floor};
318	my $is_wall = 0;	305	my $is_wall = 0;
…		…
368	$x * ($w - 8) + 4,	355	$x * ($w - 8) + 4,
369	$y * ($h - 8) + 4;	356	$y * ($h - 8) + 4;
370	}	357	}
371	}	358	}
372		359
373	system "convert -depth 8 $SRC rgba:-"	360	system "$CONVERT -depth 8 $SRC rgba:-"
374	. "\| $exec_prefix/bin/cfhq2xa $w $h 0"	361	. "\| $exec_prefix/bin/cfhq2xa $w $h 0"
375	. "\| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $CROP $QUANTIZE -quality 00 png32:\Q$other\E~"	362	. "\| $CONVERT -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $CROP $QUANTIZE -quality 00 png32:\Q$other\E~"
376	and die "convert/cfhq2xa pipeline error: status $? ($!)";	363	and die "convert/cfhq2xa pipeline error: status $? ($!)";
377	system $OPTIPNG, "-i0", "-q", "$other~";	364	optipng "$other~";
378	die "$other~ has zero size, aborting." unless -s "$other~";
379	rename "$other~", $other;	365	rename "$other~", $other;
380	};	366	};
381	}	367	};
382		368
383	push @c_png, [$other, !$CACHE];	369	push @c_png, [$other, !$CACHE];
384	}	370	}
385		371
386	# possibly scale down	372	# possibly scale down
387	if (0 > aio_stat "$stem.32x32.png") {	373	if (0 > aio_stat "$stem.32x32.png") {
388	my $other = "$stem.32x32.png~";	374	my $other = "$stem.32x32.png~";
389		375
390	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	376	make_file $path, $other, sub {
391	fork_sub {	377	fork_exec {
392	system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";	378	system "$CONVERT png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
393	system $OPTIPNG, "-i0", "-q", "$other~";	379	optipng "$other~";
394		380
395	# reduce smoothfaces >10000 bytes	381	# reduce smoothfaces >10000 bytes
396	# obsolete, no longer required	382	# obsolete, no longer required
397	if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {	383	if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
398	my $ncolor = 256;	384	my $ncolor = 256;
399	while () {	385	while () {
400	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";	386	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
401	system $OPTIPNG, "-i0", "-q", "$other~~";	387	optipng "$other~~";
402	last if 10000 > -s "$other~~";	388	last if 10000 > -s "$other~~";
403	$ncolor = int $ncolor * 0.9;	389	$ncolor = int $ncolor * 0.9;
404	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";	390	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
405	}	391	}
406		392
…		…
411	}	397	}
412		398
413	die "$other~ has zero size, aborting." unless -s "$other~";	399	die "$other~ has zero size, aborting." unless -s "$other~";
414	rename "$other~", $other;	400	rename "$other~", $other;
415	};	401	};
416	}	402	};
417		403
418	#warn "scaled down $path to $other\n";#d#	404	#warn "scaled down $path to $other\n";#d#
419	push @c_png, [$other, !$CACHE];	405	push @c_png, [$other, !$CACHE];
420	}	406	}
421	}	407	}
422		408
423	(my $face = $stem) =~ s/^.*\///;	409	(my $face = $stem) =~ s/^.*\///;
		410
		411	for (@{ $fi->{derive} }) {
		412	my ($dir, $type) = @$_;
		413
		414	my $geom = "${T}x${T}";
		415	my $dpath = "$dir/$type:$face.$geom.png~";
		416
		417	if ($type eq "buildmaterial") {
		418	my $ov = "$PATH/mapbuilding/buildmaterial.png";
		419	make_file [$path, $ov], $dpath, sub {
		420	fork_exec {
		421	system "$CONVERT -size 64x64 xc:transparent \$ \Q$path\E -geometry 52x52+6+6 \$ -composite \Q$ov\E -composite -geometry $geom png:\Q$dpath\E~";
		422	optipng "$dpath~";
		423	rename "$dpath~", $dpath;
		424	};
		425	};
		426	} elsif ($type eq "buildmaterial-box") {
		427	my $ov = "$PATH/mapbuilding/buildmaterial-box.png";
		428	make_file [$path, $ov], $dpath, sub {
		429	fork_exec {
		430	system "$CONVERT \Q$ov\E "
		431	. "\\( \Q$path\E -trim -geometry 34x31\\> "
		432	. "-gravity center -background transparent -extent 37x34 +gravity "
		433	. "-geometry +22+6 \\) -composite "
		434	. "-geometry $geom png:\Q$dpath\E~";
		435	optipng "$dpath~";
		436	rename "$dpath~", $dpath;
		437	};
		438	};
		439	} elsif ($type eq "buildmaterial-sbox") {
		440	my $ov = "$PATH/mapbuilding/buildmaterial-sbox.png";
		441	make_file [$path, $ov], $dpath, sub {
		442	fork_exec {
		443	system "$CONVERT \Q$ov\E "
		444	. "\\( \Q$path\E -trim -geometry 16x24\\> "
		445	. "-gravity center -background transparent -extent 18x26 +gravity "
		446	. "-geometry +26+16 \\) -composite "
		447	. "-geometry $geom png:\Q$dpath\E~";
		448	optipng "$dpath~";
		449	rename "$dpath~", $dpath;
		450	};
		451	};
		452	} else {
		453	warn "ERROR: facename $type:$face contains unsupported derivation type.\n";
		454	}
		455
		456	aio_load $dpath, my $png;
		457	IO::AIO::aio_unlink $dpath unless $CACHE;
		458	commit_png "$dir/$type:$face", "$type:$face", $png, $T, 1, 1;
		459	}
424		460
425	# split all bigfaces, but avoid smoothfaces (*_S)	461	# split all bigfaces, but avoid smoothfaces (*_S)
426	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {	462	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {
427	# split	463	# split
428	my @tile;	464	my @tile;
…		…
433	push @tile, [$x, $y, $file, (stat _)[9]];	469	push @tile, [$x, $y, $file, (stat _)[9]];
434	}	470	}
435	}	471	}
436		472
437	my $mtime = (lstat $path)[9];	473	my $mtime = (lstat $path)[9];
438	my @todo = grep { $_->[3] <= $mtime } @tile;	474	my @todo = grep { $_->[3] < $mtime } @tile;
439	if (@todo) {	475	if (@todo) {
440	fork_sub {	476	fork_exec {
441	open my $convert, "\|-", $CONVERT,	477	open my $convert, "\|-", $CONVERT,
442	"png:-",	478	"png:-",
443	(map {	479	(map {
444	(	480	(
445	"(",	481	"(",
…		…
458	print $convert $png;	494	print $convert $png;
459	close $convert;	495	close $convert;
460		496
461	# pass 2, optimise, and rename	497	# pass 2, optimise, and rename
462	for (@todo) {	498	for (@todo) {
463	system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";	499	optipng "$_->[2]~";
464	die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
465	rename "$_->[2]~", $_->[2];	500	rename "$_->[2]~", $_->[2];
466	}	501	}
467	};	502	};
468	}	503	}
469		504
…		…
473		508
474	if (0 > aio_load $file, $tile) {	509	if (0 > aio_load $file, $tile) {
475	die "$path: unable to read tile +$x+$y, aborting.\n";	510	die "$path: unable to read tile +$x+$y, aborting.\n";
476	}	511	}
477	IO::AIO::aio_unlink $file unless $CACHE;	512	IO::AIO::aio_unlink $file unless $CACHE;
478	commit_png $stem, $x\|$y ? "$face+$x+$y" : $face, $tile, $T;	513	commit_png $stem, $x\|$y ? "$face+$x+$y" : $face, $tile, $T, 1, 1;
479	}	514	}
480	} else {	515	} else {
481	# use as-is (either small, use smooth)	516	# use as-is (either small, use smooth)
482	commit_png $stem, $face, $png, $T;	517	commit_png $stem, $face, $png, $T, $w / $T, $h / $T;
483	}	518	}
484		519
485	aio_unlink $path if $delete;	520	IO::AIO::aio_unlink $path if $delete;
486	}	521	}
487	}	522	}
488		523
489	sub process_faceinfo {	524	sub process_faceinfo {
490	my ($dir, $file) = @_;	525	my ($dir, $file) = @_;
491	my $path = "$dir/$file";	526	my $path = "$dir/$file";
492		527
493	my $data;	528	my $data;
494	if (0 > aio_load $path, $data) {	529	if (0 > aio_load $path, $data) {
495	warn "$path: $!, skipping.\n";	530	warn "ERROR: $path: $!, skipping.\n";
496	return;	531	return;
497	}	532	}
498		533
499	for (split /\n/, $data) {	534	for (split /\n/, $data) {
		535	chomp;
500	my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/;	536	my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
		537	# bg not used except for text clients
501		538
		539	utf8::decode $glyph;
502	$glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag	540	$glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag
		541	$glyph =~ s/^"(.+)"$/$1/; # allow for ""-style quoting
		542
		543	$fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet
503		544
504	(my $fgi = $COLOR{$fg})	545	(my $fgi = $COLOR{$fg})
505	// warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n";	546	// warn "ERROR: $path: $face specifies unknown foreground colour '$fg'.\n";
506	(my $bgi = $COLOR{$bg})	547	(my $bgi = $COLOR{$bg})
507	// warn "WARNING: $path: $face specifies unknown background colour '$bg'.\n";	548	// warn "ERROR: $path: $face specifies unknown background colour '$bg'.\n";
508		549
509	my $fi = $FACEINFO{$face} \|\|= { };	550	my $fi = $FACEINFO{$face} \|\|= { };
510	$fi->{visibility} = $visibility * 1;	551	$fi->{visibility} = $visibility * 1;
511	$fi->{magicmap} = $fgi; # foreground colour becomes magicmap	552	$fi->{magicmap} = $fgi; # foreground colour becomes magicmap
		553
		554	$glyph .= " " if 2 > length $glyph; # TODO kanji
		555	die "glyph $face too long" if 2 < length $glyph;
		556
		557	$fi->{glyph} = "";
		558	for (split //, $glyph) {
		559	utf8::encode $_;
512	$fi->{glyph} = (chr $fgi) . (chr $bgi) . $glyph;	560	$fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
513	#$fi->{glyph} = (chr $fgi) . $glyph;#d#TOOD remove	561	}
514	# bg not used except for text clients
515	}	562	}
516	}	563	}
517		564
518	sub process_arc {	565	sub process_arc {
519	while (my ($dir, $file) = @{ $c_arc->get }) {	566	while (my ($dir, $file) = @{ $c_arc->get }) {
…		…
575	next if /^facings\s/;	622	next if /^facings\s/;
576		623
577	my $face = $_;	624	my $face = $_;
578	$face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates	625	$face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
579		626
580	my $info = $FACEINFO{$face} \|\|= { };	627	# handle derived faces
		628	if ($face =~ /^([^:]+):(.*)/) {
		629	my ($type, $base) = ($1, $2);
		630	push @{ $FACEINFO{$base}{derive} }, [$dir, $type];
		631	}
		632
581	$info->{arc} = $o;	633	$FACEINFO{$face}{arc} = $o;
582		634
583	next if $face =~ /^blank.x11$\|^empty.x11$/;	635	next if $face =~ /^blank.x11$\|^empty.x11$/;
584	}	636	}
585		637
586	if (my $smooth = delete $o->{smoothface}) {	638	if (my $smooth = delete $o->{smoothface}) {
…		…
602	my ($dir, $file) = @_;	654	my ($dir, $file) = @_;
603	my $path = "$dir/$file";	655	my $path = "$dir/$file";
604		656
605	my $trs;	657	my $trs;
606	if (0 > aio_load $path, $trs) {	658	if (0 > aio_load $path, $trs) {
607	warn "$path: $!, skipping.\n";	659	warn "ERROR: $path: $!, skipping.\n";
608	return;	660	return;
609	}	661	}
610		662
611	$TRS .= $trs;	663	$TRS .= $trs;
612	}	664	}
…		…
617	unless (exists $FILECACHE{$_[0]}) {	669	unless (exists $FILECACHE{$_[0]}) {
618	my $data;	670	my $data;
619	if (0 < aio_load $_[0], $data) {	671	if (0 < aio_load $_[0], $data) {
620	if ($_[1]) {	672	if ($_[1]) {
621	$data = eval { $_[1]->($data) };	673	$data = eval { $_[1]->($data) };
622	warn "$_[0]: $@" if $@;	674	warn "ERROR: $_[0]: $@" if $@;
623	}	675	}
624	}	676	}
625		677
626	$FILECACHE{$_[0]} = $data;	678	$FILECACHE{$_[0]} = $data;
627	}	679	}
628		680
629	$FILECACHE{$_[0]}	681	$FILECACHE{$_[0]}
		682	}
		683
		684	# convert an image and a palette to some indexed 2d-matrix structure
		685	sub process_plt {
		686	my ($base, $plt) = @_;
		687
		688	my ($w, $h) = imgsize "$base.png";
		689
		690	$w * $h
		691	or die "$base.png: unable to identify correct size\n";
		692
		693	my @plt;
		694	my %map;
		695
		696	for (split /\n/, $plt) {
		697	next unless /\S/;
		698	next if /^\s*#/;
		699
		700	/^([0-9a-fA-F]{3,6})\s(.?)\s*$/
		701	or die "unparseable palette entry for $base.plt: $_";
		702
		703	my ($rgb, $name) = ($1, $2);
		704
		705	$rgb =~ s/^(.)(.)(.)$/$1$1$2$2$3$3/;
		706
		707	$map{pack "H*", $rgb} = chr @plt;
		708	push @plt, $name;
		709	}
		710
		711	make_file ["$base.plt", "$base.png"], "$base.tbl~", sub {
		712	warn "building $base\n" if $VERBOSE >= 3;
		713
		714	fork_exec {
		715	open my $png, "-\|", $CONVERT, qw(-depth 8 --), "$base.png", "rgb:"
		716	or die "$base.png: $!";
		717
		718	local $/;
		719	$png = <$png>;
		720
		721	$w * $h * 3 == length $png
		722	or die "$base.png: failed to read enough data from file\n";
		723
		724	$png =~ s/(...)/$map{$1}/ge;
		725
		726	$w * $h == length $png
		727	or die "$base.png: failed to map all data - wrong palette?\n";
		728
		729	{
		730	open my $fh, ">:raw", "$base.tbl~~"
		731	or die "$base.tbl~~: $!";
		732	syswrite $fh, $png;
		733	}
		734
		735	rename "$base.tbl~~", "$base.tbl~";
		736	};
		737	};
		738
		739	0 <= aio_load "$base.tbl~", my $tbl
		740	or die "$base.tbl~: $!";
		741
		742	IO::AIO::aio_unlink "$base.tbl~" unless $CACHE;
		743
		744	Compress::LZF::compress nfreeze {
		745	w => $w,
		746	h => $h,
		747	plt => \@plt,
		748	tbl => $tbl,
		749	}
630	}	750	}
631		751
632	sub process_res {	752	sub process_res {
633	my ($dir, $file, $type) = @_;	753	my ($dir, $file, $type) = @_;
634		754
635	my $data;
636	aio_load "$dir/$file", $data;	755	0 <= aio_load "$dir/$file", my $data
		756	or die "$dir/$file: $!";
637		757
638	my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };	758	my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
639		759
640	utf8::decode $dir;	760	utf8::decode $dir;
641	utf8::decode $file;	761	utf8::decode $file;
…		…
649	$meta = {	769	$meta = {
650	%{ $meta->{"" } \|\| {} },	770	%{ $meta->{"" } \|\| {} },
651	%{ $meta->{$file} \|\| {} },	771	%{ $meta->{$file} \|\| {} },
652	};	772	};
653		773
654	if ($meta->{license} =~ s/^#//) {	774	if (exists $meta->{license} && $meta->{license} =~ s/^#//) { # exists == avoid autovivification
		775	# all these are acceptable for deliantra - if not specified, agpl 3+ is the default.
655	$meta->{license} = ({	776	$meta->{license} = ({
656	"pd" => "Public Domain",	777	"pd" => "Public Domain",
657	"gpl" => "GNU General Public License, version 3.0 or any later",	778	"gpl" => "GNU General Public License, version 3.0 or any later",
		779	"2bsd" => "2-clause BSD/MIT style license",
		780	"3bsd" => "3-clause BSD style license",
658	"cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",	781	"cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
659	"cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",	782	"cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
660	"cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",	783	"cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
661	"cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",	784	"cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
662	})->{$meta->{license}}	785	})->{$meta->{license}}
663	\|\| warn "$dir/$file: license tag '$meta->{license}' not found.";	786	\|\| warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
664	}	787	}
665		788
666	if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {	789	if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
667	($meta->{author} = $1) =~ s/_/ /g;	790	($meta->{author} = $1) =~ s/_/ /g;
668	}	791	}
669		792
670	$file =~ s/\.res$//;	793	$file =~ s/\.res$//;
671	$file =~ s/\.(ogg\|wav\|jpg\|png)$//;	794	$file =~ s/\.(ogg\|wav\|jpg\|png)$//;
672		795
673	substr $dir, 0, 1 + length $PATH, "";	796	if ($file =~ s/\.plt$//) {
674		797	$data = process_plt "$dir/$file", $data;
675	if (my $filter = $meta->{cfutil_filter}) {	798	} elsif (my $filter = delete $meta->{cfutil_filter}) {
676	if ($filter eq "yaml2json") {	799	if ($filter eq "yaml2json") {
677	$data = JSON::XS::encode_json YAML::XS::Load $data;	800	$data = JSON::XS::encode_json YAML::XS::Load $data;
678	} elsif ($filter eq "json2json") {	801	} elsif ($filter eq "json2json") {
679	$data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);	802	$data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
680	} elsif ($filter eq "perl2json") {	803	} elsif ($filter eq "perl2json") {
681	$data = eval $data; die if $@;	804	$data = eval $data; die if $@;
682	$data = JSON::XS::encode_json $data;	805	$data = JSON::XS::encode_json $data;
683	} else {	806	} else {
684	warn "$dir/$file: unknown filter $filter, skipping\n";	807	warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
685	}
686	}	808	}
		809	}
687		810
688	$RESOURCE{"$dir/$file"} = {	811	substr $dir, 0, 1 + length $PATH, "";
		812
		813	my %info = (
689	type => (exists $meta->{type} ? delete $meta->{type} : $type),	814	type => (exists $meta->{type} ? delete $meta->{type} : $type),
690	data => $data,	815	data => $data,
691	%$meta ? (meta => $meta) : (),	816	%$meta ? (meta => $meta) : (),
692	};	817	);
		818
		819	$RESOURCE{"$dir/$file"} = \%info;
693	}	820	}
694		821
695	sub process_any {	822	sub process_any {
696	while (my ($func, @args) = @{ $c_any->get }) {	823	while (my ($func, @args) = @{ $c_any->get }) {
697	$func->(@args);	824	$func->(@args);
…		…
730	if ($file =~ /\.(jpg\|png)$/) {	857	if ($file =~ /\.(jpg\|png)$/) {
731	$c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE	858	$c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
732	} elsif ($file =~ /\.(res)$/) {	859	} elsif ($file =~ /\.(res)$/) {
733	$c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC	860	$c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
734	} else {	861	} else {
735	$c_any->put ([\&process_res, $path, $file, undef]);	862	$c_any->put ([\&process_res, $path, $file, 6]); # was type undef, but now meta files are mandatory, so any mentioned file surely has a purpose
736	}	863	}
737		864
738	} elsif ($file =~ /\.png$/) {	865	} elsif ($file =~ /\.png$/) {
739	push @c_png, ["$path/$file", 0];	866	$PNG{$file} = $path;
740		867
741	} elsif ($file =~ /\.faceinfo$/) {	868	} elsif ($file =~ /\.faceinfo$/) {
742	$c_any->put ([\&process_faceinfo, $path, $file]);	869	$c_any->put ([\&process_faceinfo, $path, $file]);
743		870
744	} elsif ($file =~ /\.trs$/) {	871	} elsif ($file =~ /\.trs$/) {
…		…
797	"Unless you run verbosely, all following warning\n",	924	"Unless you run verbosely, all following warning\n",
798	"or error messages indicate serious problems.\n",	925	"or error messages indicate serious problems.\n",
799	"\n";	926	"\n";
800		927
801	if (!-d "$path/treasures") {	928	if (!-d "$path/treasures") {
802	warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";	929	warn "FATAL: '$path' does not look like an arch directory ('treasures' directory is missing).\n";
803	exit 1 unless $FORCE;	930	exit 1 unless $FORCE;
804	}	931	}
805		932
806	print "start file scan, arc, any processing...\n" if $VERBOSE;	933	print "starting file scan, arc, any processing...\n" if $VERBOSE;
807		934
808	my @a_arc = map +(async \&process_arc), 1..2;	935	my @a_arc = map +(async \&process_arc), 1..2;
809	my @a_any = map +(async \&process_any), 1..4;	936	my @a_any = map +(async \&process_any), 1..4;
810		937
811	find_files $path;	938	find_files $path;
812		939
813	$c_arc->shutdown;	940	$c_arc->shutdown;
814	$c_any->shutdown;	941	$c_any->shutdown;
815		942
816	$_->join for @a_arc; # need to parse all archetypes before png processing	943	$_->join for @a_arc; # need to parse all archetypes before png processing
		944	print "finished arc processing...\n" if $VERBOSE;
817		945
		946	# fill png queue
		947	for (keys %FACEINFO) {
		948	# we only expect source pngs to exist for non-derived
		949	# faces, i.e. no split tiles (+x+x) and no face derivates
		950	# (xxx:)
		951	/^[^:]+\....$/
		952	or next;
		953
		954	my $seen;
		955
		956	if (exists $PNG{"$_.32x32.png"}) {
		957	push @c_png, ["$PNG{\"$_.32x32.png\"}/$_.32x32.png"];
		958	$seen = 1;
		959	}
		960	if (exists $PNG{"$_.64x64.png"}) {
		961	push @c_png, ["$PNG{\"$_.64x64.png\"}/$_.64x64.png"];
		962	$seen = 1;
		963	}
		964
		965	warn "ERROR: $_: face not found, expect problems.\n"
		966	unless $seen;
		967	}
		968
818	print "end arc, start png processing...\n" if $VERBOSE;	969	print "starting png processing...\n" if $VERBOSE;
819		970
820	# eight png crunchers work fine for my 4x smp machine	971	# eight png crunchers work fine for my 4x smp machine
821	my @a_png = map +(async \&process_png), 1..8;	972	my @a_png = map +(async \&process_png), 1..8;
822		973
823	print "end any processing...\n" if $VERBOSE;
824	$_->join for @a_any;	974	$_->join for @a_any;
825
826	print "end png processing...\n" if $VERBOSE;	975	print "finished any processing...\n" if $VERBOSE;
		976
827	$_->join for @a_png;	977	$_->join for @a_png;
		978	print "finished png processing...\n" if $VERBOSE;
828		979
829	print "scanning done, processing results...\n" if $VERBOSE;	980	print "scanning done, processing results...\n" if $VERBOSE;
830	{	981	{
831	# remove path prefix from editor_folder	982	# remove path prefix from editor_folder
832	$_->{editor_folder} =~ /^\x00/	983	$_->{editor_folder} =~ /^\x00/
…		…
850	delete @s{qw(_name more name name_pl)};	1001	delete @s{qw(_name more name name_pl)};
851	%$o = ( %s, %$o );	1002	%$o = ( %s, %$o );
852	++$progress;	1003	++$progress;
853	}	1004	}
854	} else {	1005	} else {
855	warn "WARNING: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";	1006	warn "ERROR: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
856	delete $ARC{$o->{_name}};	1007	delete $ARC{$o->{_name}};
857	}	1008	}
858	}	1009	}
859	}	1010	}
860		1011
…		…
887	open my $fh, ">:utf8", "$DATADIR/archetypes~"	1038	open my $fh, ">:utf8", "$DATADIR/archetypes~"
888	or die "$DATADIR/archetypes~: $!";	1039	or die "$DATADIR/archetypes~: $!";
889	print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];	1040	print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
890	}	1041	}
891		1042
892	if (WRITE_FACEINFO) {
893	my @table;
894	for my $face (sort keys %FACEINFO) {
895	my $v = $FACEINFO{$face};
896	(my $xf = $face) =~ s/\+\d+\+\d+$//;
897
898	$v->{magicmap} //= $FACEINFO{$xf}{magicmap};
899	$v->{glyph} //= $FACEINFO{$xf}{glyph};
900
901	$v->{magicmap} =~ y/A-Z_\-/a-z/d;
902
903	delete $v->{glyph} if $v->{glyph} =~ /^\?./;
904
905	my $stem = $v->{stem};
906	$v->{glyph} = $v->{glyph} // ("?" . (autoglyph $stem, $v));
907
908	push @table, [$face, $v->{visibility} \|\| 0, $v->{magicmap} \|\| "none", "none ", $v->{glyph}];
909	}
910	use Text::Table;
911	my $tb = new Text::Table undef, { align => "num" }, undef, undef, undef;
912	$tb->load (@table);
913	open my $fh, ">:raw", "default.faceinfo"or die;
914	print $fh $tb;
915	print "default.faceinfo written, exiting.\n";
916	exit 77;
917	}
918
919	{	1043	{
920	printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;	1044	printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
921	open my $fh, ">:utf8", "$DATADIR/treasures~"	1045	open my $fh, ">:utf8", "$DATADIR/treasures~"
922	or die "$DATADIR/treasures~: $!";	1046	or die "$DATADIR/treasures~: $!";
923	print $fh $TRS;	1047	print $fh $TRS;
924	}	1048	}
925		1049
926	{	1050	{
927	print "processing facedata...\n" if $VERBOSE;	1051	print "processing facedata...\n" if $VERBOSE;
928	while (my ($k, $v) = each %FACEINFO) {	1052
		1053	for my $k (sort keys %FACEINFO) {
		1054	my $v = $FACEINFO{$k};
		1055
929	length $v->{data32} or warn "WARNING: face '$k' has no png32. this will not work (shoddy gcfclient will crash of course).\n";	1056	length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
930	length $v->{data64} or warn "WARNING: face '$k' has no png64. this will not work very well.\n";	1057	length $v->{data64} or warn "ERROR: face '$k' has no png64 - this will not work.\n";
931		1058
932	make_hash $k, $v->{data32}, $v->{hash32};	1059	make_hash $k, $v->{data32}, $v->{hash32};
933	make_hash $k, $v->{data64}, $v->{hash64};	1060	make_hash $k, $v->{data64}, $v->{hash64};
934		1061
935	#length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";	1062	#length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
936	#length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";	1063	#length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
937		1064
938	exists $v->{visibility}	1065	$v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
939	or warn "WARNING: face '$k' has no visibility info, missing faceinfo entry?\n";	1066	$v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
		1067	$v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
940		1068
941	my $stem = delete $v->{stem};	1069	if (0 && $v->{w} == 1 && $v->{h} == 1) { # texture catalogs
942	$v->{glyph} // warn "WARNING: face '$k' has glyph, cannot autoglyph at the moment.";	1070	my $id = @TC;
943	#$v->{glyph} //= autoglyph $stem, $v;	1071	my $n = @{ $TC[-1] };
		1072	my $x = $n % TC_W;
		1073	my $y = int $n / TC_W;
944		1074
945	delete $v->{arc};	1075	push @{ $TC[-1] }, [$v, $x, $y];
		1076
		1077	$v->{tc} = [$id, $x, $y];
		1078
		1079	push @TC, [] if $n == TC_W * TC_H - 1; # start new texture if full
946	}	1080	}
		1081
		1082	delete @$v{qw(w h arc stem derive)}; # not used by the server
		1083	}
		1084
		1085	if (0) { #d# texture catalogs
		1086	print "creating texture catalogs...\n" if $VERBOSE;
		1087
		1088	for my $id (0 .. $#TC) {
		1089	my $tc = $TC[$id];
		1090
		1091	my $cmd = "$CONVERT -depth 8 -size " . (TC_W * 64) . "x" . (TC_H * 64) . " xc:transparent";
		1092	my $idx = "a";
		1093
		1094	for (@$tc) {
		1095	my $path = "$TMPDIR/tc" . $idx++;
		1096
		1097	open my $fh, ">:perlio", $path
		1098	or die "$path: $!";
		1099	syswrite $fh, $_->[0]{data64};
		1100
		1101	my $x = $_->[1] * 64;
		1102	my $y = $_->[2] * 64;
		1103
		1104	$cmd .= " png:\Q$path\E -geometry +$x+$y -composite";
		1105	}
		1106
		1107	system "$cmd png:\Q$TMPDIR/tc$id\E";
		1108	optipng "$TMPDIR/tc$id";
		1109	}
		1110	}
947		1111
948	print "processing resources...\n" if $VERBOSE;	1112	print "processing resources...\n" if $VERBOSE;
949	my $enc = JSON::XS->new->utf8->canonical->relaxed;	1113	my $enc = JSON::XS->new->utf8->canonical->relaxed;
950	while (my ($k, $v) = each %RESOURCE) {	1114	for my $k (sort keys %RESOURCE) {
		1115	my $v = $RESOURCE{$k};
951		1116
952	if ($v->{meta} && $v->{meta}{datadir}) {	1117	if ($v->{meta} && $v->{meta}{datadir}) {
953	delete $RESOURCE{$k};	1118	delete $RESOURCE{$k};
954		1119
955	$k =~ s/^res\/// or die "$k: datadir files must be in res/";	1120	$k =~ s/^res\/// or die "$k: datadir files must be in res/";
…		…
974		1139
975	make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients	1140	make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
976	}	1141	}
977	}	1142	}
978		1143
		1144	printf "writing facedata...\n" if $VERBOSE;
		1145
		1146	{
		1147	open my $fh, ">:perlio", "$DATADIR/facedata~"
		1148	or die "$DATADIR/facedata~: $!";
		1149
		1150	print $fh "FACEDATA";
		1151	my $fofs = 8;
		1152
		1153	my $put = sub {
		1154	my $len = length $_[0];
		1155	my $ofs = $fofs;
		1156
		1157	print $fh $_[0];
		1158	$fofs += $len;
		1159
		1160	($len, $ofs)
		1161	};
		1162
		1163	for (values %FACEINFO) {
		1164	($_->{size32}, $_->{fofs32}) = $put->(delete $_->{data32});
		1165	($_->{size64}, $_->{fofs64}) = $put->(delete $_->{data64});
		1166	}
		1167
		1168	for (values %RESOURCE) {
		1169	($_->{size}, $_->{fofs}) = $put->(delete $_->{data});
		1170	}
		1171
		1172	close $fh;
		1173	}
		1174
979	printf "writing facedata (%d faces, %d anims, %d resources)...\n",	1175	printf "writing faceinfo (%d faces, %d anims, %d resources)...\n",
980	scalar keys %FACEINFO,	1176	scalar keys %FACEINFO,
981	scalar keys %ANIMINFO,	1177	scalar keys %ANIMINFO,
982	scalar keys %RESOURCE	1178	scalar keys %RESOURCE
983	if $VERBOSE;	1179	if $VERBOSE;
984		1180
985	open my $fh, ">:perlio", "$DATADIR/facedata~"	1181	open my $fh, ">:perlio", "$DATADIR/faceinfo~"
986	or die "$DATADIR/facedata~: $!";	1182	or die "$DATADIR/faceinfo~: $!";
987		1183
988	print $fh nfreeze {	1184	print $fh nfreeze {
989	version => 2,	1185	version => 2,
990	faceinfo => \%FACEINFO,	1186	faceinfo => \%FACEINFO,
991	animinfo => \%ANIMINFO,	1187	animinfo => \%ANIMINFO,
992	resource => \%RESOURCE,	1188	resource => \%RESOURCE,
993	};	1189	};
994
995	}	1190	}
996		1191
997	print "committing files...\n" if $VERBOSE;	1192	print "committing files...\n" if $VERBOSE;
998		1193
999	for (qw(archetypes facedata treasures), @COMMIT) {	1194	for (qw(archetypes faceinfo facedata treasures), @COMMIT) {
1000	chmod 0644, "$DATADIR/$_~";	1195	chmod 0644, "$DATADIR/$_~";
1001	rename "$DATADIR/$_~", "$DATADIR/$_"	1196	rename "$DATADIR/$_~", "$DATADIR/$_"
1002	or die "$DATADIR/$_: $!";	1197	or die "$DATADIR/$_: $!";
1003	}	1198	}
1004		1199

Diff Legend

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

Comparing deliantra/server/utils/cfutil.in (file contents): Revision 1.104 by root, Sat Oct 16 22:12:18 2010 UTC vs. Revision 1.125 by root, Mon Nov 19 00:40:55 2012 UTC

Diff Legend

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.104 by root, Sat Oct 16 22:12:18 2010 UTC vs.
Revision 1.125 by root, Mon Nov 19 00:40:55 2012 UTC