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

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.57 by root, Mon Aug 20 22:09:04 2007 UTC vs.
Revision 1.125 by root, Mon Nov 19 00:40:55 2012 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,2012 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 Coro::Util;	54	use Coro::Util;
25	use POSIX ();
26	use Carp;
27	use Coro::Channel;	55	use Coro::Channel;
		56	use Coro::AnyEvent;
28	use Coro::Storable; $Storable::canonical = 1;	57	use Coro::Storable; $Storable::canonical = 1;
		58
		59	use Deliantra;
29		60
30	$SIG{QUIT} = sub { Carp::cluck "QUIT" };	61	$SIG{QUIT} = sub { Carp::cluck "QUIT" };
31		62
32	sub usage {	63	sub usage {
33	warn <<EOF;	64	warn <<EOF;
46	my $VERBOSE = 1;	77	my $VERBOSE = 1;
47	my $CACHE = 0;	78	my $CACHE = 0;
48	my $FORCE;	79	my $FORCE;
49	my $TMPDIR = "/tmp/cfutil$$~";	80	my $TMPDIR = "/tmp/cfutil$$~";
50	my $TMPFILE = "aaaa0";	81	my $TMPFILE = "aaaa0";
		82	my @COMMIT;
51		83
52	our %COLOR = (	84	our %COLOR = (
		85	# original cf colours
53	black => 0,	86	black => 0,
54	white => 1,	87	white => 1,
55	navy => 2,	88	navy => 2, # "dark blue"
56	red => 3,	89	red => 3,
57	orange => 4,	90	orange => 4,
58	blue => 5,	91	blue => 5, # "light blue"
59	darkorange => 6,	92	darkorange => 6,
60	green => 7,	93	green => 7,
61	lightgreen => 8,	94	lightgreen => 8,
62	grey => 9,	95	grey => 9,
		96	brown => 10, # "yellow"
		97	gold => 11, # "light yellow"
		98	tan => 12, # yellowish gray
		99
		100	# new for deliantra
63	brown => 10,	101	none => 13,
		102
		103	# compatibility to existing archetypes
		104	lightblue => 5,
64	gold => 11,	105	gray => 9,
		106	yellow => 11,
65	tan => 12,	107	khaki => 12,
66	);	108	);
67		109
68	END { system "rm", "-rf", $TMPDIR }	110	END { system "rm", "-rf", $TMPDIR }
69		111
70	Event->signal (signal => "INT", cb => sub { exit 1 });	112	my $s_INT = AE::signal INT => sub { exit 1 };
71	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	}
72		141
73	mkdir $TMPDIR, 0700	142	mkdir $TMPDIR, 0700
74	or die "$TMPDIR: $!";	143	or die "$TMPDIR: $!";
75		144
76	sub fork_sub(&) {	145	sub fork_exec(&) {
77	my ($cb) = @_;	146	my ($cb) = @_;
78		147
79	if (my $pid = fork) {	148	if (my $pid = fork) {
80	my $current = $Coro::current;	149	my $current = $Coro::current;
81	my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });	150	my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
…		…
86	warn $@;	155	warn $@;
87	POSIX::_exit 1;	156	POSIX::_exit 1;
88	}	157	}
89	}	158	}
90		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
91	sub inst_maps($) {	189	sub inst_maps($) {
92	my (undef, $path) = @_;	190	my (undef, $path) = @_;
93		191
94	print "\nInstalling '$path' to '$DATADIR/maps'\n\n";	192	print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
95		193
96	if (!-f "$path/regions") {	194	if (!-f "$path/regions") {
97	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";
98	exit 1 unless $FORCE;	196	exit 1 unless $FORCE;
99	}	197	}
100		198
101	system $RSYNC, "-a", "--chmod=u=rwX,go=rX", "$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"
102	and die "map installation failed.\n";	203	and die "map installation failed.\n";
103		204
104	print "maps installed successfully.\n";	205	print "maps installed successfully.\n";
105	}	206	}
106		207
…		…
109	our %FACEINFO;	210	our %FACEINFO;
110	our %RESOURCE;	211	our %RESOURCE;
111	our @ARC;	212	our @ARC;
112	our %ARC;	213	our %ARC;
113	our $TRS;	214	our $TRS;
		215	our %PNG;
114	our $NFILE;	216	our $NFILE;
115	our $PATH;	217	our $PATH;
116		218
117	our $QUANTIZE = "+dither -colorspace RGB -colors 256";	219	our $QUANTIZE = "+dither -colorspace RGB -colors 256";
118		220
119	our $c_arc = new Coro::Channel;	221	our $c_arc = new Coro::Channel;
120	our $c_trs = new Coro::Channel;	222	our $c_any = new Coro::Channel;
121	our $c_res = new Coro::Channel;
122		223
123	our @c_png;	224	our @c_png;
124		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
125	sub commit_png($$$) {	232	sub commit_png($$$$$$) {
126	my ($name, $data, $T) = @_;	233	my ($stem, $name, $data, $T, $w, $h) = @_;
127		234
		235	$FACEINFO{$name}{stem} = substr $stem, 1 + length $PATH;
128	$FACEINFO{$name}{"data$T"} = $data;	236	$FACEINFO{$name}{"data$T"} = $data;
		237	$FACEINFO{$name}{w} = $w;
		238	$FACEINFO{$name}{h} = $h;
129	}	239	}
130		240
131	sub process_png {	241	sub process_png {
132	while (@c_png) {	242	while (@c_png) {
133	my ($path, $delete) = @{pop @c_png};	243	my ($path, $delete) = @{pop @c_png};
…		…
135	my $png;	245	my $png;
136	aio_lstat $path;	246	aio_lstat $path;
137	my ($size, $mtime) = (stat _)[7,9];	247	my ($size, $mtime) = (stat _)[7,9];
138		248
139	if (0 > aio_load $path, $png) {	249	if (0 > aio_load $path, $png) {
140	warn "$path: $!, skipping.\n";	250	warn "ERROR: $path: $!, skipping.\n";
141	next;	251	next;
142	}	252	}
143		253
144	my $stem = $path;	254	my $stem = $path;
145	my $T;	255	my $T;
…		…
147	if ($stem =~ s/\.32x32\.png~?$//) {	257	if ($stem =~ s/\.32x32\.png~?$//) {
148	$T = 32;	258	$T = 32;
149	} elsif ($stem =~ s/\.64x64\.png~?$//) {	259	} elsif ($stem =~ s/\.64x64\.png~?$//) {
150	$T = 64;	260	$T = 64;
151	} else {	261	} else {
152	warn "$path: weird filename, skipping.\n";	262	warn "ERROR: $path: weird filename, skipping.\n";
153	next;	263	next;
154	}	264	}
155		265
156	# quickly extract width and height of the (necessarily PNG) image	266	# quickly extract width and height of the (necessarily PNG) image
157	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {	267	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
158	warn "$path: not a recognized png file, skipping.\n";	268	warn "ERROR: $path: not a recognized png file, skipping.\n";
159	next;	269	next;
160	}	270	}
161		271
162	my ($w, $h) = unpack "NN", $1;	272	my ($w, $h) = unpack "NN", $1;
163		273
164	if ($w < $T \|\| $h < $T) {	274	if ($w < $T \|\| $h < $T) {
165	warn "$path: too small ($w $h), skipping.\n";	275	warn "ERROR: $path: too small ($w $h), skipping.\n";
166	next;	276	next;
167	}	277	}
168		278
169	if ($w % $T \|\| $h % $T) {	279	if ($w % $T \|\| $h % $T) {
170	warn "$path: weird png size ($w $h), skipping.\n";	280	warn "ERROR: $path: weird png size ($w $h), skipping.\n";
171	next;	281	next;
172	}	282	}
173		283
174	(my $base = $stem) =~ s/^.*\///;	284	(my $base = $stem) =~ s/^.*\///;
175		285
176	my $fi = $FACEINFO{$base};	286	my $fi = $FACEINFO{$base};
177	unless ($fi) {	287	unless ($fi) {
178	warn "$path: <$base> not referenced by any archetype, skipping.\n";	288	#warn "$path: <$base> not referenced by any archetype, skipping.\n";
179	next;	289	#next;
180	}	290	}
181		291
182	my $arc = $FACEINFO{$base}{arc}	292	my $arc = $fi->{arc} \|\| { };
183	or die "FATAL: internal error <$base>, cannot continue";
184		293
185	unless ($path =~ /~$/) {	294	unless ($path =~ /~$/) {
186	# possibly enlarge	295	# possibly enlarge
187	if (0 > aio_stat "$stem.64x64.png") {	296	if (0 > aio_stat "$stem.64x64.png") {
188	my $other = "$stem.64x64.png~";	297	my $other = "$stem.64x64.png~";
189		298
190	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	299	make_file $path, $other, sub {
191	fork_sub {	300	fork_exec {
192	my $CROP;	301	my $CROP;
193	my $SRC = "png:\Q$path\E";	302	my $SRC = "png:\Q$path\E";
194		303
195	my $is_floor = $arc->{is_floor};	304	my $is_floor = $arc->{is_floor};
196	my $is_wall = 0;	305	my $is_wall = 0;
…		…
246	$x * ($w - 8) + 4,	355	$x * ($w - 8) + 4,
247	$y * ($h - 8) + 4;	356	$y * ($h - 8) + 4;
248	}	357	}
249	}	358	}
250		359
251	system "convert -depth 8 $SRC rgba:-"	360	system "$CONVERT -depth 8 $SRC rgba:-"
252	. "\| $exec_prefix/bin/cfhq2xa $w $h 0"	361	. "\| $exec_prefix/bin/cfhq2xa $w $h 0"
253	. "\| 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~"
254	and die "convert/cfhq2xa pipeline error: status $? ($!)";	363	and die "convert/cfhq2xa pipeline error: status $? ($!)";
255	system $OPTIPNG, "-i0", "-q", "$other~";	364	optipng "$other~";
256	die "$other~ has zero size, aborting." unless -s "$other~";
257	rename "$other~", $other;	365	rename "$other~", $other;
258	};	366	};
259	}	367	};
260		368
261	push @c_png, [$other, !$CACHE];	369	push @c_png, [$other, !$CACHE];
262	}	370	}
263		371
264	# possibly scale down	372	# possibly scale down
265	if (0 > aio_stat "$stem.32x32.png") {	373	if (0 > aio_stat "$stem.32x32.png") {
266	my $other = "$stem.32x32.png~";	374	my $other = "$stem.32x32.png~";
267		375
268	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	376	make_file $path, $other, sub {
269	fork_sub {	377	fork_exec {
270	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~";
271	system $OPTIPNG, "-i0", "-q", "$other~";	379	optipng "$other~";
272		380
273	# reduce smoothfaces >10000 bytes	381	# reduce smoothfaces >10000 bytes
		382	# obsolete, no longer required
274	if ($stem =~ /_S\./ && (-s "$other~") > 10000) {	383	if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
275	my $ncolor = 256;	384	my $ncolor = 256;
276	while () {	385	while () {
277	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";	386	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
278	system $OPTIPNG, "-i0", "-q", "$other~~";	387	optipng "$other~~";
279	last if 10000 > -s "$other~~";	388	last if 10000 > -s "$other~~";
280	$ncolor = int $ncolor * 0.9;	389	$ncolor = int $ncolor * 0.9;
281	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";	390	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
282	}	391	}
283		392
…		…
288	}	397	}
289		398
290	die "$other~ has zero size, aborting." unless -s "$other~";	399	die "$other~ has zero size, aborting." unless -s "$other~";
291	rename "$other~", $other;	400	rename "$other~", $other;
292	};	401	};
293	}	402	};
294		403
295	#warn "scaled down $path to $other\n";#d#	404	#warn "scaled down $path to $other\n";#d#
296	push @c_png, [$other, !$CACHE];	405	push @c_png, [$other, !$CACHE];
297	}	406	}
298	}	407	}
299		408
300	(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	}
301		460
302	# split all bigfaces, but avoid smoothfaces (*_S)	461	# split all bigfaces, but avoid smoothfaces (*_S)
303	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {	462	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {
304	# split	463	# split
305	my @tile;	464	my @tile;
…		…
310	push @tile, [$x, $y, $file, (stat _)[9]];	469	push @tile, [$x, $y, $file, (stat _)[9]];
311	}	470	}
312	}	471	}
313		472
314	my $mtime = (lstat $path)[9];	473	my $mtime = (lstat $path)[9];
315	my @todo = grep { $_->[3] <= $mtime } @tile;	474	my @todo = grep { $_->[3] < $mtime } @tile;
316	if (@todo) {	475	if (@todo) {
317	fork_sub {	476	fork_exec {
318	open my $convert, "\|-", $CONVERT,	477	open my $convert, "\|-", $CONVERT,
319	"png:-",	478	"png:-",
320	(map {	479	(map {
321	(	480	(
322	"(",	481	"(",
…		…
335	print $convert $png;	494	print $convert $png;
336	close $convert;	495	close $convert;
337		496
338	# pass 2, optimise, and rename	497	# pass 2, optimise, and rename
339	for (@todo) {	498	for (@todo) {
340	system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";	499	optipng "$_->[2]~";
341	die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
342	rename "$_->[2]~", $_->[2];	500	rename "$_->[2]~", $_->[2];
343	}	501	}
344	};	502	};
345	}	503	}
346		504
…		…
350		508
351	if (0 > aio_load $file, $tile) {	509	if (0 > aio_load $file, $tile) {
352	die "$path: unable to read tile +$x+$y, aborting.\n";	510	die "$path: unable to read tile +$x+$y, aborting.\n";
353	}	511	}
354	IO::AIO::aio_unlink $file unless $CACHE;	512	IO::AIO::aio_unlink $file unless $CACHE;
355	commit_png $x\|$y ? "$face+$x+$y" : $face, $tile, $T;	513	commit_png $stem, $x\|$y ? "$face+$x+$y" : $face, $tile, $T, 1, 1;
356	}	514	}
357	} else {	515	} else {
358	# use as-is (either small, use smooth)	516	# use as-is (either small, use smooth)
359	commit_png $face, $png, $T;	517	commit_png $stem, $face, $png, $T, $w / $T, $h / $T;
360	}	518	}
361		519
362	aio_unlink $path if $delete;	520	IO::AIO::aio_unlink $path if $delete;
		521	}
		522	}
		523
		524	sub process_faceinfo {
		525	my ($dir, $file) = @_;
		526	my $path = "$dir/$file";
		527
		528	my $data;
		529	if (0 > aio_load $path, $data) {
		530	warn "ERROR: $path: $!, skipping.\n";
		531	return;
		532	}
		533
		534	for (split /\n/, $data) {
		535	chomp;
		536	my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
		537	# bg not used except for text clients
		538
		539	utf8::decode $glyph;
		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
		544
		545	(my $fgi = $COLOR{$fg})
		546	// warn "ERROR: $path: $face specifies unknown foreground colour '$fg'.\n";
		547	(my $bgi = $COLOR{$bg})
		548	// warn "ERROR: $path: $face specifies unknown background colour '$bg'.\n";
		549
		550	my $fi = $FACEINFO{$face} \|\|= { };
		551	$fi->{visibility} = $visibility * 1;
		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 $_;
		560	$fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
		561	}
363	}	562	}
364	}	563	}
365		564
366	sub process_arc {	565	sub process_arc {
367	while (my $job = $c_arc->get) {	566	while (my ($dir, $file) = @{ $c_arc->get }) {
368	my ($dir, $file) = @$job;
369
370	my $arc;	567	my $arc;
371	aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/	568	aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
372		569
373	my $arc = read_arch "$dir/$file";	570	my $arc = read_arch "$dir/$file";
374	for my $o (values %$arc) {	571	for my $o (values %$arc) {
375	push @ARC, $o;	572	push @ARC, $o;
376	for (my $m = $o; $m; $m = $m->{more}) {	573	for (my $m = $o; $m; $m = $m->{more}) {
377	$ARC{$m->{_name}} = $m;	574	$ARC{$m->{_name}} = $m;
378	}	575	}
379		576
380	$o->{editor_folder} = $dir;	577	$o->{editor_folder} \|\|= "\x00$dir"; # horrible kludge
381
382	my $visibility = delete $o->{visibility};
383	my $magicmap = delete $o->{magicmap};
384		578
385	# find upper left corner :/	579	# find upper left corner :/
386	# omg, this is sooo broken	580	# omg, this is sooo broken
387	my ($dx, $dy);	581	my ($dx, $dy);
388	for (my $o = $o; $o; $o = $o->{more}) {	582	for (my $o = $o; $o; $o = $o->{more}) {
…		…
395	my $y = $o->{y} - $dy;	589	my $y = $o->{y} - $dy;
396		590
397	my $ext = $x\|$y ? "+$x+$y" : "";	591	my $ext = $x\|$y ? "+$x+$y" : "";
398		592
399	$o->{face} .= $ext unless /^blank.x11$\|^empty.x11$/ \|\| !$o->{face};	593	$o->{face} .= $ext unless /^blank.x11$\|^empty.x11$/ \|\| !$o->{face};
400
401	$visibility = delete $o->{visibility} if exists $o->{visibility};
402	$magicmap = delete $o->{magicmap} if exists $o->{magicmap};
403		594
404	my $anim = delete $o->{anim};	595	my $anim = delete $o->{anim};
405		596
406	if ($anim) {	597	if ($anim) {
407	# possibly add $ext to the animation name to avoid	598	# possibly add $ext to the animation name to avoid
…		…
425	facings => $facings,	616	facings => $facings,
426	frames => \@frames,	617	frames => \@frames,
427	};	618	};
428	}	619	}
429		620
430	for my $face ($o->{face} \|\| (), @{$anim \|\| []}) {	621	for ($o->{face} \|\| (), @{$anim \|\| []}) {
431	next if $face =~ /^facings\s/;	622	next if /^facings\s/;
432		623
433	my $info = $FACEINFO{$face} \|\|= { };
434	$info->{arc} = $o;	624	my $face = $_;
		625	$face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
		626
		627	# handle derived faces
		628	if ($face =~ /^([^:]+):(.*)/) {
		629	my ($type, $base) = ($1, $2);
		630	push @{ $FACEINFO{$base}{derive} }, [$dir, $type];
		631	}
		632
		633	$FACEINFO{$face}{arc} = $o;
435		634
436	next if $face =~ /^blank.x11$\|^empty.x11$/;	635	next if $face =~ /^blank.x11$\|^empty.x11$/;
437
438	$info->{visibility} = $visibility if defined $visibility;
439	$info->{magicmap} = $magicmap if defined $magicmap;
440	}	636	}
441		637
442	if (my $smooth = delete $o->{smoothface}) {	638	if (my $smooth = delete $o->{smoothface}) {
443	my %kv = split /\s+/, $smooth;	639	my %kv = split /\s+/, $smooth;
444	my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support	640	my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
…		…
453	}	649	}
454	}	650	}
455	}	651	}
456		652
457	sub process_trs {	653	sub process_trs {
458	while (my $job = $c_trs->get) {
459	my ($dir, $file) = @$job;	654	my ($dir, $file) = @_;
460	my $path = "$dir/$file";	655	my $path = "$dir/$file";
461		656
462	my $trs;	657	my $trs;
463	if (0 > aio_load $path, $trs) {	658	if (0 > aio_load $path, $trs) {
464	warn "$path: $!, skipping.\n";	659	warn "ERROR: $path: $!, skipping.\n";
465	next;	660	return;
466	}	661	}
467		662
468	$TRS .= $trs;	663	$TRS .= $trs;
469	}
470	}	664	}
471		665
472	my %FILECACHE;	666	my %FILECACHE;
473		667
474	sub load_cached($;$) {	668	sub load_cached($;$) {
475	unless (exists $FILECACHE{$_[0]}) {	669	unless (exists $FILECACHE{$_[0]}) {
476	my $data;	670	my $data;
477	if (0 < aio_load $_[0], $data) {	671	if (0 < aio_load $_[0], $data) {
478	if ($_[1]) {	672	if ($_[1]) {
479	$data = eval { $_[1]->($data) };	673	$data = eval { $_[1]->($data) };
480	warn "$_[0]: $@" if $@;	674	warn "ERROR: $_[0]: $@" if $@;
481	}	675	}
482	}	676	}
483		677
484	$FILECACHE{$_[0]} = $data;	678	$FILECACHE{$_[0]} = $data;
485	}	679	}
486		680
487	$FILECACHE{$_[0]}	681	$FILECACHE{$_[0]}
488	}	682	}
489		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	}
		750	}
		751
490	sub process_res {	752	sub process_res {
491	while (my $job = $c_res->get) {
492	my ($dir, $file, $type) = @$job;	753	my ($dir, $file, $type) = @_;
493		754
494	my $data;
495	aio_load "$dir/$file", $data;	755	0 <= aio_load "$dir/$file", my $data
		756	or die "$dir/$file: $!";
496		757
497	my $meta = load_cached "$dir/meta", sub { JSON::XS::from_json shift };	758	my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
498		759
499	next if $meta && !exists $meta->{$file};	760	utf8::decode $dir;
		761	utf8::decode $file;
500		762
		763	# a meta file for resources is now mandatory
		764	unless (exists $meta->{$file}) {
		765	warn "skipping $dir/$file\n" if $VERBOSE >= 3;
		766	return;
		767	}
		768
501	$meta = {	769	$meta = {
502	%{ $meta->{"" } \|\| {} },	770	%{ $meta->{"" } \|\| {} },
503	%{ $meta->{$file} \|\| {} },	771	%{ $meta->{$file} \|\| {} },
504	};	772	};
505		773
506	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.
507	$meta->{license} = ({	776	$meta->{license} = ({
508	"pd" => "Public Domain",	777	"pd" => "Public Domain",
509	"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",
510	"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/",
		782	"cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
511	"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/",
512	"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/",
513	})->{$meta->{license}}	785	})->{$meta->{license}}
514	\|\| warn "$dir/$file: license tag '$meta->{license}' not found.";	786	\|\| warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
515	}	787	}
516		788
		789	if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
		790	($meta->{author} = $1) =~ s/_/ /g;
		791	}
		792
517	$file =~ s/\.res$//;	793	$file =~ s/\.res$//;
518	$file =~ s/\.(ogg\|wav\|jpg\|png)$//;	794	$file =~ s/\.(ogg\|wav\|jpg\|png)$//;
519		795
		796	if ($file =~ s/\.plt$//) {
		797	$data = process_plt "$dir/$file", $data;
		798	} elsif (my $filter = delete $meta->{cfutil_filter}) {
		799	if ($filter eq "yaml2json") {
		800	$data = JSON::XS::encode_json YAML::XS::Load $data;
		801	} elsif ($filter eq "json2json") {
		802	$data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
		803	} elsif ($filter eq "perl2json") {
		804	$data = eval $data; die if $@;
		805	$data = JSON::XS::encode_json $data;
		806	} else {
		807	warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
		808	}
		809	}
		810
520	substr $dir, 0, 1 + length $PATH, "";	811	substr $dir, 0, 1 + length $PATH, "";
521		812
522	$RESOURCE{"$dir/$file"} = {	813	my %info = (
523	type => (delete $meta->{type}) \|\| $type,	814	type => (exists $meta->{type} ? delete $meta->{type} : $type),
524	data => $data,	815	data => $data,
525	%$meta ? (meta => $meta) : (),	816	%$meta ? (meta => $meta) : (),
526	};	817	);
		818
		819	$RESOURCE{"$dir/$file"} = \%info;
		820	}
		821
		822	sub process_any {
		823	while (my ($func, @args) = @{ $c_any->get }) {
		824	$func->(@args);
527	}	825	}
528	}	826	}
529		827
530	sub find_files;	828	sub find_files;
531	sub find_files {	829	sub find_files {
532	my ($path) = @_;	830	my ($path) = @_;
533		831
		832	my $grp = IO::AIO::aio_group;
		833
		834	my $scandir; $scandir = sub {
		835	my ($path) = @_;
		836
534	IO::AIO::aioreq_pri 4;	837	IO::AIO::aioreq_pri 4;
535	IO::AIO::aio_scandir $path, 4, sub {	838	add $grp IO::AIO::aio_scandir $path, 4, sub {
536	my ($dirs, $nondirs) = @_;	839	my ($dirs, $nondirs) = @_;
537		840
538	find_files "$path/$_"	841	$scandir->("$path/$_")
539	for grep $_ !~ /^(?:CVS\|dev)$/, @$dirs;	842	for grep $_ !~ /^(?:CVS\|dev\|\..*)$/, @$dirs;
540		843
541	my $dir = $path;	844	my $dir = $path;
542	substr $dir, 0, 1 + length $PATH, "";	845	substr $dir, 0, 1 + length $PATH, "";
543		846
544	for my $file (@$nondirs) {	847	for my $file (@$nondirs) {
545	if ($dir =~ /^music(?:\/\|$)/) {	848	if ($dir =~ /^music(?:\/\|$)/) {
546	$c_res->put ([$path, $file, 3]) # FT_MUSIC	849	$c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
547	if $file =~ /\.(ogg)$/;	850	if $file =~ /\.(ogg)$/;
548		851
549	} elsif ($dir =~ /^sound(?:\/\|$)/) {	852	} elsif ($dir =~ /^sound(?:\/\|$)/) {
550	$c_res->put ([$path, $file, 5]) # FT_SOUND	853	$c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
551	if $file =~ /\.(wav\|ogg)$/;	854	if $file =~ /\.(wav\|ogg)$/;
552		855
553	} elsif ($dir =~ /^res(?:\/\|$)/) {	856	} elsif ($dir =~ /^res(?:\/\|$)/) {
554	$c_res->put ([$path, $file, 0]) # FT_FACE
555	if $file =~ /\.(jpg\|png)$/;	857	if ($file =~ /\.(jpg\|png)$/) {
556	$c_res->put ([$path, $file, 7]) # FT_RSRC	858	$c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
557	if $file =~ /\.(res)$/;	859	} elsif ($file =~ /\.(res)$/) {
		860	$c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
		861	} else {
		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
		863	}
558		864
559	} elsif ($file =~ /\.png$/) {	865	} elsif ($file =~ /\.png$/) {
560	push @c_png, ["$path/$file", 0];	866	$PNG{$file} = $path;
561		867
		868	} elsif ($file =~ /\.faceinfo$/) {
		869	$c_any->put ([\&process_faceinfo, $path, $file]);
		870
562	} elsif ($file =~ /\.trs$/) {	871	} elsif ($file =~ /\.trs$/) {
563	$c_trs->put ([$path, $file]);	872	$c_any->put ([\&process_trs, $path, $file]);
564		873
565	} elsif ($file =~ /\.arc$/) {	874	} elsif ($file =~ /\.arc$/) {
566	$c_arc->put ([$path, $file]);	875	$c_arc->put ([$path, $file]);
567		876
568	} else {	877	} else {
569	warn "ignoring $path/$file\n" if $VERBOSE >= 3;	878	warn "ignoring $path/$file\n" if $VERBOSE >= 3;
570	}	879	}
		880	}
571	}	881	};
572	};	882	};
		883
		884	$scandir->($path);
		885	aio_wait $grp;
		886	}
		887
		888	sub generate_plurals {
		889	# use Lingua::EN::Inflect ();
		890	# Lingua::EN::Inflect::classical;
		891	# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
		892	# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
		893	#
		894	# for my $a (@ARC) {
		895	# my $name = $a->{name} \|\| $a->{_name};
		896	#
		897	# next unless $a->{name_pl};
		898	# next if $a->{invisible};
		899	# next if $a->{is_floor};
		900	# next if $a->{no_pick};
		901	#
		902	# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
		903	# my $pl = $test =~ /^(?:eq\|p:.)$/
		904	# ? $name
		905	# : Lingua::EN::Inflect::PL $name;
		906	#
		907	# if ($pl ne $a->{name_pl}) {
		908	# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
		909	# }
		910	# }
573	}	911	}
574		912
575	sub inst_arch($) {	913	sub inst_arch($) {
576	my (undef, $path) = @_;	914	my (undef, $path) = @_;
577		915
…		…
586	"Unless you run verbosely, all following warning\n",	924	"Unless you run verbosely, all following warning\n",
587	"or error messages indicate serious problems.\n",	925	"or error messages indicate serious problems.\n",
588	"\n";	926	"\n";
589		927
590	if (!-d "$path/treasures") {	928	if (!-d "$path/treasures") {
591	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";
592	exit 1 unless $FORCE;	930	exit 1 unless $FORCE;
593	}	931	}
594		932
595	print "scanning files...\n" if $VERBOSE;	933	print "starting file scan, arc, any processing...\n" if $VERBOSE;
		934
		935	my @a_arc = map +(async \&process_arc), 1..2;
		936	my @a_any = map +(async \&process_any), 1..4;
596		937
597	find_files $path;	938	find_files $path;
598		939
599	my @a_arc = map +(async \&process_arc), 1..2;	940	$c_arc->shutdown;
600	my @a_res = map +(async \&process_res), 1..2;	941	$c_any->shutdown;
601	my @a_trs = map +(async \&process_trs), 1..2;
602
603	IO::AIO::flush;
604
605	$c_res->put (undef) for @a_res;
606	$c_arc->put (undef) for @a_arc;
607	$c_trs->put (undef) for @a_trs;
608
609	print "start file scan, arc, res processing...\n" if $VERBOSE;
610		942
611	$_->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;
612		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
613	print "end arc, start png processing...\n" if $VERBOSE;	969	print "starting png processing...\n" if $VERBOSE;
614		970
615	# four png crunchers work fine for my 2x smp machine	971	# eight png crunchers work fine for my 4x smp machine
616	my @a_png = map +(async \&process_png), 1..4;	972	my @a_png = map +(async \&process_png), 1..8;
617		973
618	$_->join for (@a_trs, @a_res, @a_png);	974	$_->join for @a_any;
		975	print "finished any processing...\n" if $VERBOSE;
		976
		977	$_->join for @a_png;
		978	print "finished png processing...\n" if $VERBOSE;
619		979
620	print "scanning done, processing results...\n" if $VERBOSE;	980	print "scanning done, processing results...\n" if $VERBOSE;
621	{	981	{
622	# remove path prefix from editor_folder	982	# remove path prefix from editor_folder
		983	$_->{editor_folder} =~ /^\x00/
623	substr $_->{editor_folder}, 0, 1 + length $path, ""	984	and substr $_->{editor_folder}, 0, 2 + length $path, ""
624	for values %ARC;	985	for values %ARC;
625		986
626	print "resolving inheritance tree...\n" if $VERBOSE;	987	print "resolving inheritance tree...\n" if $VERBOSE;
627	# resolve inherit	988	# resolve inherit
628	while () {	989	while () {
629	my $progress;	990	my $progress;
630	my $loop;	991	my $loop;
631		992
632	for my $o (values %ARC) {	993	for my $o (values %ARC) {
633	if (my $other = $o->{inherit}) {	994	for my $other (split /,/, $o->{inherit}) {
634	if (my $s = $ARC{$other}) {	995	if (my $s = $ARC{$other}) {
635	if ($s->{inherit}) {	996	if ($s->{inherit}) {
636	$loop = $s;	997	$loop = $s;
637	} else {	998	} else {
638	delete $o->{inherit};	999	delete $o->{inherit};
…		…
640	delete @s{qw(_name more name name_pl)};	1001	delete @s{qw(_name more name name_pl)};
641	%$o = ( %s, %$o );	1002	%$o = ( %s, %$o );
642	++$progress;	1003	++$progress;
643	}	1004	}
644	} else {	1005	} else {
645	warn "'$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";
646	delete $ARC{$o->{_name}};	1007	delete $ARC{$o->{_name}};
647	}	1008	}
648	}	1009	}
649	}	1010	}
650		1011
…		…
657	}	1018	}
658		1019
659	# remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit	1020	# remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
660	@ARC = grep $_->{_name} !~ /^(?:type\|class)_/, @ARC;	1021	@ARC = grep $_->{_name} !~ /^(?:type\|class)_/, @ARC;
661		1022
		1023	# fix up archetypes without names, where the archanme doesn't work at all
		1024	for (@ARC) {
		1025	if (!exists $_->{name} and $_->{_name} =~ /_/) {
		1026	for ($_->{name} = $_->{_name}) {
		1027	s/(?:_\d+)+$//;
		1028	s/_[nesw]+$//;
		1029	y/_/ /;
		1030	}
		1031	}
		1032	}
		1033
		1034	#print "generating plurals...\n" if $VERBOSE;
		1035	#generate_plurals;
		1036
662	print "writing archetypes...\n" if $VERBOSE;	1037	printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
663	open my $fh, ">:utf8", "$DATADIR/archetypes~"	1038	open my $fh, ">:utf8", "$DATADIR/archetypes~"
664	or die "$DATADIR/archetypes~: $!";	1039	or die "$DATADIR/archetypes~: $!";
665	print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];	1040	print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
666	}	1041	}
667		1042
668	{	1043	{
669	print "writing treasures...\n" if $VERBOSE;	1044	printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
670	open my $fh, ">:utf8", "$DATADIR/treasures~"	1045	open my $fh, ">:utf8", "$DATADIR/treasures~"
671	or die "$DATADIR/treasures~: $!";	1046	or die "$DATADIR/treasures~: $!";
672	print $fh $TRS;	1047	print $fh $TRS;
673	}	1048	}
674		1049
675	{	1050	{
676	print "processing facedata...\n" if $VERBOSE;	1051	print "processing facedata...\n" if $VERBOSE;
677	while (my ($k, $v) = each %FACEINFO) {
678	length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
679	length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
680
681	length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";
682	#length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
683
684	if (my $magicmap = $v->{magicmap}) {
685	$magicmap =~ y/A-Z_\-/a-z/d;
686	$v->{magicmap} = $COLOR{$magicmap};
687	}
688
689	delete $v->{arc};
690	}	1052
		1053	for my $k (sort keys %FACEINFO) {
		1054	my $v = $FACEINFO{$k};
691		1055
		1056	length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
		1057	length $v->{data64} or warn "ERROR: face '$k' has no png64 - this will not work.\n";
		1058
		1059	make_hash $k, $v->{data32}, $v->{hash32};
		1060	make_hash $k, $v->{data64}, $v->{hash64};
		1061
		1062	#length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
		1063	#length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
		1064
		1065	$v->{glyph} // warn "ERROR: face '$k' has no glyph - 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";
		1068
		1069	if (0 && $v->{w} == 1 && $v->{h} == 1) { # texture catalogs
		1070	my $id = @TC;
		1071	my $n = @{ $TC[-1] };
		1072	my $x = $n % TC_W;
		1073	my $y = int $n / TC_W;
		1074
		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
		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	}
		1111
		1112	print "processing resources...\n" if $VERBOSE;
		1113	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		1114	for my $k (sort keys %RESOURCE) {
		1115	my $v = $RESOURCE{$k};
		1116
		1117	if ($v->{meta} && $v->{meta}{datadir}) {
		1118	delete $RESOURCE{$k};
		1119
		1120	$k =~ s/^res\/// or die "$k: datadir files must be in res/";
		1121
		1122	printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
		1123	open my $fh, ">:raw", "$DATADIR/$k~"
		1124	or die "$DATADIR/$k~: $!";
		1125	syswrite $fh, $v->{data};
		1126	push @COMMIT, $k;
		1127
		1128	} else {
		1129	if ($v->{type} & 1) {
		1130	# prepend meta info
		1131
		1132	my $meta = $enc->encode ({
		1133	name => $k,
		1134	%{ $v->{meta} \|\| {} },
		1135	});
		1136
		1137	$v->{data} = pack "(w/a)", $meta, $v->{data};
		1138	}
		1139
		1140	make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
		1141	}
		1142	}
		1143
692	print "writing facedata...\n" if $VERBOSE;	1144	printf "writing facedata...\n" if $VERBOSE;
		1145
		1146	{
693	open my $fh, ">:perlio", "$DATADIR/facedata~"	1147	open my $fh, ">:perlio", "$DATADIR/facedata~"
694	or die "$DATADIR/facedata~: $!";	1148	or die "$DATADIR/facedata~: $!";
695		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
		1175	printf "writing faceinfo (%d faces, %d anims, %d resources)...\n",
		1176	scalar keys %FACEINFO,
		1177	scalar keys %ANIMINFO,
		1178	scalar keys %RESOURCE
		1179	if $VERBOSE;
		1180
		1181	open my $fh, ">:perlio", "$DATADIR/faceinfo~"
		1182	or die "$DATADIR/faceinfo~: $!";
		1183
696	print $fh freeze {	1184	print $fh nfreeze {
697	version => 2,	1185	version => 2,
698	faceinfo => \%FACEINFO,	1186	faceinfo => \%FACEINFO,
699	animinfo => \%ANIMINFO,	1187	animinfo => \%ANIMINFO,
700	resource => \%RESOURCE,	1188	resource => \%RESOURCE,
701	};	1189	};
702	}	1190	}
703		1191
704	print "committing files...\n" if $VERBOSE;	1192	print "committing files...\n" if $VERBOSE;
705		1193
706	for (qw(archetypes facedata treasures)) {	1194	for (qw(archetypes faceinfo facedata treasures), @COMMIT) {
707	chmod 0644, "$DATADIR/$_~";	1195	chmod 0644, "$DATADIR/$_~";
708	rename "$DATADIR/$_~", "$DATADIR/$_"	1196	rename "$DATADIR/$_~", "$DATADIR/$_"
709	or die "$DATADIR/$_: $!";	1197	or die "$DATADIR/$_: $!";
710	}	1198	}
711		1199

Diff Legend

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

Comparing deliantra/server/utils/cfutil.in (file contents): Revision 1.57 by root, Mon Aug 20 22:09:04 2007 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.57 by root, Mon Aug 20 22:09:04 2007 UTC vs.
Revision 1.125 by root, Mon Nov 19 00:40:55 2012 UTC