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

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.61 by root, Thu Aug 30 07:13:17 2007 UTC vs.
Revision 1.124 by root, Sun Nov 11 05:53:12 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
…		…
184	unless ($path =~ /~$/) {	294	unless ($path =~ /~$/) {
185	# possibly enlarge	295	# possibly enlarge
186	if (0 > aio_stat "$stem.64x64.png") {	296	if (0 > aio_stat "$stem.64x64.png") {
187	my $other = "$stem.64x64.png~";	297	my $other = "$stem.64x64.png~";
188		298
189	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	299	make_file $path, $other, sub {
190	fork_sub {	300	fork_exec {
191	my $CROP;	301	my $CROP;
192	my $SRC = "png:\Q$path\E";	302	my $SRC = "png:\Q$path\E";
193		303
194	my $is_floor = $arc->{is_floor};	304	my $is_floor = $arc->{is_floor};
195	my $is_wall = 0;	305	my $is_wall = 0;
…		…
245	$x * ($w - 8) + 4,	355	$x * ($w - 8) + 4,
246	$y * ($h - 8) + 4;	356	$y * ($h - 8) + 4;
247	}	357	}
248	}	358	}
249		359
250	system "convert -depth 8 $SRC rgba:-"	360	system "$CONVERT -depth 8 $SRC rgba:-"
251	. "\| $exec_prefix/bin/cfhq2xa $w $h 0"	361	. "\| $exec_prefix/bin/cfhq2xa $w $h 0"
252	. "\| 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~"
253	and die "convert/cfhq2xa pipeline error: status $? ($!)";	363	and die "convert/cfhq2xa pipeline error: status $? ($!)";
254	system $OPTIPNG, "-i0", "-q", "$other~";	364	optipng "$other~";
255	die "$other~ has zero size, aborting." unless -s "$other~";
256	rename "$other~", $other;	365	rename "$other~", $other;
257	};	366	};
258	}	367	};
259		368
260	push @c_png, [$other, !$CACHE];	369	push @c_png, [$other, !$CACHE];
261	}	370	}
262		371
263	# possibly scale down	372	# possibly scale down
264	if (0 > aio_stat "$stem.32x32.png") {	373	if (0 > aio_stat "$stem.32x32.png") {
265	my $other = "$stem.32x32.png~";	374	my $other = "$stem.32x32.png~";
266		375
267	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	376	make_file $path, $other, sub {
268	fork_sub {	377	fork_exec {
269	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~";
270	system $OPTIPNG, "-i0", "-q", "$other~";	379	optipng "$other~";
271		380
272	# reduce smoothfaces >10000 bytes	381	# reduce smoothfaces >10000 bytes
		382	# obsolete, no longer required
273	if ($stem =~ /_S\./ && (-s "$other~") > 10000) {	383	if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
274	my $ncolor = 256;	384	my $ncolor = 256;
275	while () {	385	while () {
276	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";	386	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
277	system $OPTIPNG, "-i0", "-q", "$other~~";	387	optipng "$other~~";
278	last if 10000 > -s "$other~~";	388	last if 10000 > -s "$other~~";
279	$ncolor = int $ncolor * 0.9;	389	$ncolor = int $ncolor * 0.9;
280	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";	390	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
281	}	391	}
282		392
…		…
287	}	397	}
288		398
289	die "$other~ has zero size, aborting." unless -s "$other~";	399	die "$other~ has zero size, aborting." unless -s "$other~";
290	rename "$other~", $other;	400	rename "$other~", $other;
291	};	401	};
292	}	402	};
293		403
294	#warn "scaled down $path to $other\n";#d#	404	#warn "scaled down $path to $other\n";#d#
295	push @c_png, [$other, !$CACHE];	405	push @c_png, [$other, !$CACHE];
296	}	406	}
297	}	407	}
298		408
299	(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	}
300		460
301	# split all bigfaces, but avoid smoothfaces (*_S)	461	# split all bigfaces, but avoid smoothfaces (*_S)
302	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {	462	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {
303	# split	463	# split
304	my @tile;	464	my @tile;
…		…
309	push @tile, [$x, $y, $file, (stat _)[9]];	469	push @tile, [$x, $y, $file, (stat _)[9]];
310	}	470	}
311	}	471	}
312		472
313	my $mtime = (lstat $path)[9];	473	my $mtime = (lstat $path)[9];
314	my @todo = grep { $_->[3] <= $mtime } @tile;	474	my @todo = grep { $_->[3] < $mtime } @tile;
315	if (@todo) {	475	if (@todo) {
316	fork_sub {	476	fork_exec {
317	open my $convert, "\|-", $CONVERT,	477	open my $convert, "\|-", $CONVERT,
318	"png:-",	478	"png:-",
319	(map {	479	(map {
320	(	480	(
321	"(",	481	"(",
…		…
334	print $convert $png;	494	print $convert $png;
335	close $convert;	495	close $convert;
336		496
337	# pass 2, optimise, and rename	497	# pass 2, optimise, and rename
338	for (@todo) {	498	for (@todo) {
339	system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";	499	optipng "$_->[2]~";
340	die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
341	rename "$_->[2]~", $_->[2];	500	rename "$_->[2]~", $_->[2];
342	}	501	}
343	};	502	};
344	}	503	}
345		504
…		…
349		508
350	if (0 > aio_load $file, $tile) {	509	if (0 > aio_load $file, $tile) {
351	die "$path: unable to read tile +$x+$y, aborting.\n";	510	die "$path: unable to read tile +$x+$y, aborting.\n";
352	}	511	}
353	IO::AIO::aio_unlink $file unless $CACHE;	512	IO::AIO::aio_unlink $file unless $CACHE;
354	commit_png $x\|$y ? "$face+$x+$y" : $face, $tile, $T;	513	commit_png $stem, $x\|$y ? "$face+$x+$y" : $face, $tile, $T, 1, 1;
355	}	514	}
356	} else {	515	} else {
357	# use as-is (either small, use smooth)	516	# use as-is (either small, use smooth)
358	commit_png $face, $png, $T;	517	commit_png $stem, $face, $png, $T, $w / $T, $h / $T;
359	}	518	}
360		519
361	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	}
362	}	562	}
363	}	563	}
364		564
365	sub process_arc {	565	sub process_arc {
366	while (my $job = $c_arc->get) {	566	while (my ($dir, $file) = @{ $c_arc->get }) {
367	my ($dir, $file) = @$job;
368
369	my $arc;	567	my $arc;
370	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 :/
371		569
372	my $arc = read_arch "$dir/$file";	570	my $arc = read_arch "$dir/$file";
373	for my $o (values %$arc) {	571	for my $o (values %$arc) {
374	push @ARC, $o;	572	push @ARC, $o;
375	for (my $m = $o; $m; $m = $m->{more}) {	573	for (my $m = $o; $m; $m = $m->{more}) {
376	$ARC{$m->{_name}} = $m;	574	$ARC{$m->{_name}} = $m;
377	}	575	}
378		576
379	$o->{editor_folder} = $dir;	577	$o->{editor_folder} \|\|= "\x00$dir"; # horrible kludge
380
381	my $visibility = delete $o->{visibility};
382	my $magicmap = delete $o->{magicmap};
383		578
384	# find upper left corner :/	579	# find upper left corner :/
385	# omg, this is sooo broken	580	# omg, this is sooo broken
386	my ($dx, $dy);	581	my ($dx, $dy);
387	for (my $o = $o; $o; $o = $o->{more}) {	582	for (my $o = $o; $o; $o = $o->{more}) {
…		…
394	my $y = $o->{y} - $dy;	589	my $y = $o->{y} - $dy;
395		590
396	my $ext = $x\|$y ? "+$x+$y" : "";	591	my $ext = $x\|$y ? "+$x+$y" : "";
397		592
398	$o->{face} .= $ext unless /^blank.x11$\|^empty.x11$/ \|\| !$o->{face};	593	$o->{face} .= $ext unless /^blank.x11$\|^empty.x11$/ \|\| !$o->{face};
399
400	$visibility = delete $o->{visibility} if exists $o->{visibility};
401	$magicmap = delete $o->{magicmap} if exists $o->{magicmap};
402		594
403	my $anim = delete $o->{anim};	595	my $anim = delete $o->{anim};
404		596
405	if ($anim) {	597	if ($anim) {
406	# possibly add $ext to the animation name to avoid	598	# possibly add $ext to the animation name to avoid
…		…
430	next if /^facings\s/;	622	next if /^facings\s/;
431		623
432	my $face = $_;	624	my $face = $_;
433	$face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates	625	$face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
434		626
435	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
436	$info->{arc} = $o;	633	$FACEINFO{$face}{arc} = $o;
437		634
438	next if $face =~ /^blank.x11$\|^empty.x11$/;	635	next if $face =~ /^blank.x11$\|^empty.x11$/;
439
440	$info->{visibility} = $visibility if defined $visibility;
441	$info->{magicmap} = $magicmap if defined $magicmap;
442	}	636	}
443		637
444	if (my $smooth = delete $o->{smoothface}) {	638	if (my $smooth = delete $o->{smoothface}) {
445	my %kv = split /\s+/, $smooth;	639	my %kv = split /\s+/, $smooth;
446	my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support	640	my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
…		…
455	}	649	}
456	}	650	}
457	}	651	}
458		652
459	sub process_trs {	653	sub process_trs {
460	while (my $job = $c_trs->get) {
461	my ($dir, $file) = @$job;	654	my ($dir, $file) = @_;
462	my $path = "$dir/$file";	655	my $path = "$dir/$file";
463		656
464	my $trs;	657	my $trs;
465	if (0 > aio_load $path, $trs) {	658	if (0 > aio_load $path, $trs) {
466	warn "$path: $!, skipping.\n";	659	warn "ERROR: $path: $!, skipping.\n";
467	next;	660	return;
468	}	661	}
469		662
470	$TRS .= $trs;	663	$TRS .= $trs;
471	}
472	}	664	}
473		665
474	my %FILECACHE;	666	my %FILECACHE;
475		667
476	sub load_cached($;$) {	668	sub load_cached($;$) {
477	unless (exists $FILECACHE{$_[0]}) {	669	unless (exists $FILECACHE{$_[0]}) {
478	my $data;	670	my $data;
479	if (0 < aio_load $_[0], $data) {	671	if (0 < aio_load $_[0], $data) {
480	if ($_[1]) {	672	if ($_[1]) {
481	$data = eval { $_[1]->($data) };	673	$data = eval { $_[1]->($data) };
482	warn "$_[0]: $@" if $@;	674	warn "ERROR: $_[0]: $@" if $@;
483	}	675	}
484	}	676	}
485		677
486	$FILECACHE{$_[0]} = $data;	678	$FILECACHE{$_[0]} = $data;
487	}	679	}
488		680
489	$FILECACHE{$_[0]}	681	$FILECACHE{$_[0]}
490	}	682	}
491		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
492	sub process_res {	752	sub process_res {
493	while (my $job = $c_res->get) {
494	my ($dir, $file, $type) = @$job;	753	my ($dir, $file, $type) = @_;
495		754
496	my $data;
497	aio_load "$dir/$file", $data;	755	0 <= aio_load "$dir/$file", my $data
		756	or die "$dir/$file: $!";
498		757
499
500	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) };
501		759
502	utf8::decode $dir;	760	utf8::decode $dir;
503	utf8::decode $file;	761	utf8::decode $file;
504		762
505	# a meta file for resources is now mandatory	763	# a meta file for resources is now mandatory
506	unless (exists $meta->{$file}) {	764	unless (exists $meta->{$file}) {
507	warn "skipping $dir/$file\n" if $VERBOSE >= 3;	765	warn "skipping $dir/$file\n" if $VERBOSE >= 3;
508	next;	766	return;
509	}	767	}
510		768
511	$meta = {	769	$meta = {
512	%{ $meta->{"" } \|\| {} },	770	%{ $meta->{"" } \|\| {} },
513	%{ $meta->{$file} \|\| {} },	771	%{ $meta->{$file} \|\| {} },
514	};	772	};
515		773
516	if ($meta->{license} =~ s/^#//) {	774	if (exists $meta->{license} && $meta->{license} =~ s/^#//) { # exists == avoid autovivification
517	$meta->{license} = ({	775	$meta->{license} = ({
518	"pd" => "Public Domain",	776	"pd" => "Public Domain",
519	"gpl" => "GNU General Public License, version 3.0 or any later",	777	"gpl" => "GNU General Public License, version 3.0 or any later",
520	"cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",	778	"cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
		779	"cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
521	"cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",	780	"cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
522	"cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",	781	"cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
523	})->{$meta->{license}}	782	})->{$meta->{license}}
524	\|\| warn "$dir/$file: license tag '$meta->{license}' not found.";	783	\|\| warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
525	}	784	}
526		785
		786	if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
		787	($meta->{author} = $1) =~ s/_/ /g;
		788	}
		789
527	$file =~ s/\.res$//;	790	$file =~ s/\.res$//;
528	$file =~ s/\.(ogg\|wav\|jpg\|png)$//;	791	$file =~ s/\.(ogg\|wav\|jpg\|png)$//;
529		792
		793	if ($file =~ s/\.plt$//) {
		794	$data = process_plt "$dir/$file", $data;
		795	} elsif (my $filter = delete $meta->{cfutil_filter}) {
		796	if ($filter eq "yaml2json") {
		797	$data = JSON::XS::encode_json YAML::XS::Load $data;
		798	} elsif ($filter eq "json2json") {
		799	$data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
		800	} elsif ($filter eq "perl2json") {
		801	$data = eval $data; die if $@;
		802	$data = JSON::XS::encode_json $data;
		803	} else {
		804	warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
		805	}
		806	}
		807
530	substr $dir, 0, 1 + length $PATH, "";	808	substr $dir, 0, 1 + length $PATH, "";
531		809
532	$RESOURCE{"$dir/$file"} = {	810	my %info = (
533	type => (delete $meta->{type}) \|\| $type,	811	type => (exists $meta->{type} ? delete $meta->{type} : $type),
534	data => $data,	812	data => $data,
535	%$meta ? (meta => $meta) : (),	813	%$meta ? (meta => $meta) : (),
536	};	814	);
		815
		816	$RESOURCE{"$dir/$file"} = \%info;
		817	}
		818
		819	sub process_any {
		820	while (my ($func, @args) = @{ $c_any->get }) {
		821	$func->(@args);
537	}	822	}
538	}	823	}
539		824
540	sub find_files;	825	sub find_files;
541	sub find_files {	826	sub find_files {
542	my ($path) = @_;	827	my ($path) = @_;
543		828
		829	my $grp = IO::AIO::aio_group;
		830
		831	my $scandir; $scandir = sub {
		832	my ($path) = @_;
		833
544	IO::AIO::aioreq_pri 4;	834	IO::AIO::aioreq_pri 4;
545	IO::AIO::aio_scandir $path, 4, sub {	835	add $grp IO::AIO::aio_scandir $path, 4, sub {
546	my ($dirs, $nondirs) = @_;	836	my ($dirs, $nondirs) = @_;
547		837
548	find_files "$path/$_"	838	$scandir->("$path/$_")
549	for grep $_ !~ /^(?:CVS\|dev)$/, @$dirs;	839	for grep $_ !~ /^(?:CVS\|dev\|\..*)$/, @$dirs;
550		840
551	my $dir = $path;	841	my $dir = $path;
552	substr $dir, 0, 1 + length $PATH, "";	842	substr $dir, 0, 1 + length $PATH, "";
553		843
554	for my $file (@$nondirs) {	844	for my $file (@$nondirs) {
555	if ($dir =~ /^music(?:\/\|$)/) {	845	if ($dir =~ /^music(?:\/\|$)/) {
556	$c_res->put ([$path, $file, 3]) # FT_MUSIC	846	$c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
557	if $file =~ /\.(ogg)$/;	847	if $file =~ /\.(ogg)$/;
558		848
559	} elsif ($dir =~ /^sound(?:\/\|$)/) {	849	} elsif ($dir =~ /^sound(?:\/\|$)/) {
560	$c_res->put ([$path, $file, 5]) # FT_SOUND	850	$c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
561	if $file =~ /\.(wav\|ogg)$/;	851	if $file =~ /\.(wav\|ogg)$/;
562		852
563	} elsif ($dir =~ /^res(?:\/\|$)/) {	853	} elsif ($dir =~ /^res(?:\/\|$)/) {
564	$c_res->put ([$path, $file, 0]) # FT_FACE
565	if $file =~ /\.(jpg\|png)$/;	854	if ($file =~ /\.(jpg\|png)$/) {
566	$c_res->put ([$path, $file, 7]) # FT_RSRC	855	$c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
567	if $file =~ /\.(res)$/;	856	} elsif ($file =~ /\.(res)$/) {
		857	$c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
		858	} else {
		859	$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
		860	}
568		861
569	} elsif ($file =~ /\.png$/) {	862	} elsif ($file =~ /\.png$/) {
570	push @c_png, ["$path/$file", 0];	863	$PNG{$file} = $path;
571		864
		865	} elsif ($file =~ /\.faceinfo$/) {
		866	$c_any->put ([\&process_faceinfo, $path, $file]);
		867
572	} elsif ($file =~ /\.trs$/) {	868	} elsif ($file =~ /\.trs$/) {
573	$c_trs->put ([$path, $file]);	869	$c_any->put ([\&process_trs, $path, $file]);
574		870
575	} elsif ($file =~ /\.arc$/) {	871	} elsif ($file =~ /\.arc$/) {
576	$c_arc->put ([$path, $file]);	872	$c_arc->put ([$path, $file]);
577		873
578	} else {	874	} else {
579	warn "ignoring $path/$file\n" if $VERBOSE >= 3;	875	warn "ignoring $path/$file\n" if $VERBOSE >= 3;
580	}	876	}
		877	}
581	}	878	};
582	};	879	};
		880
		881	$scandir->($path);
		882	aio_wait $grp;
		883	}
		884
		885	sub generate_plurals {
		886	# use Lingua::EN::Inflect ();
		887	# Lingua::EN::Inflect::classical;
		888	# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
		889	# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
		890	#
		891	# for my $a (@ARC) {
		892	# my $name = $a->{name} \|\| $a->{_name};
		893	#
		894	# next unless $a->{name_pl};
		895	# next if $a->{invisible};
		896	# next if $a->{is_floor};
		897	# next if $a->{no_pick};
		898	#
		899	# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
		900	# my $pl = $test =~ /^(?:eq\|p:.)$/
		901	# ? $name
		902	# : Lingua::EN::Inflect::PL $name;
		903	#
		904	# if ($pl ne $a->{name_pl}) {
		905	# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
		906	# }
		907	# }
583	}	908	}
584		909
585	sub inst_arch($) {	910	sub inst_arch($) {
586	my (undef, $path) = @_;	911	my (undef, $path) = @_;
587		912
…		…
596	"Unless you run verbosely, all following warning\n",	921	"Unless you run verbosely, all following warning\n",
597	"or error messages indicate serious problems.\n",	922	"or error messages indicate serious problems.\n",
598	"\n";	923	"\n";
599		924
600	if (!-d "$path/treasures") {	925	if (!-d "$path/treasures") {
601	warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";	926	warn "FATAL: '$path' does not look like an arch directory ('treasures' directory is missing).\n";
602	exit 1 unless $FORCE;	927	exit 1 unless $FORCE;
603	}	928	}
604		929
605	print "scanning files...\n" if $VERBOSE;	930	print "starting file scan, arc, any processing...\n" if $VERBOSE;
		931
		932	my @a_arc = map +(async \&process_arc), 1..2;
		933	my @a_any = map +(async \&process_any), 1..4;
606		934
607	find_files $path;	935	find_files $path;
608		936
609	my @a_arc = map +(async \&process_arc), 1..2;	937	$c_arc->shutdown;
610	my @a_res = map +(async \&process_res), 1..2;	938	$c_any->shutdown;
611	my @a_trs = map +(async \&process_trs), 1..2;
612
613	IO::AIO::flush;
614
615	$c_res->put (undef) for @a_res;
616	$c_arc->put (undef) for @a_arc;
617	$c_trs->put (undef) for @a_trs;
618
619	print "start file scan, arc, res processing...\n" if $VERBOSE;
620		939
621	$_->join for @a_arc; # need to parse all archetypes before png processing	940	$_->join for @a_arc; # need to parse all archetypes before png processing
		941	print "finished arc processing...\n" if $VERBOSE;
622		942
		943	# fill png queue
		944	for (keys %FACEINFO) {
		945	# we only expect source pngs to exist for non-derived
		946	# faces, i.e. no split tiles (+x+x) and no face derivates
		947	# (xxx:)
		948	/^[^:]+\....$/
		949	or next;
		950
		951	my $seen;
		952
		953	if (exists $PNG{"$_.32x32.png"}) {
		954	push @c_png, ["$PNG{\"$_.32x32.png\"}/$_.32x32.png"];
		955	$seen = 1;
		956	}
		957	if (exists $PNG{"$_.64x64.png"}) {
		958	push @c_png, ["$PNG{\"$_.64x64.png\"}/$_.64x64.png"];
		959	$seen = 1;
		960	}
		961
		962	warn "ERROR: $_: face not found, expect problems.\n"
		963	unless $seen;
		964	}
		965
623	print "end arc, start png processing...\n" if $VERBOSE;	966	print "starting png processing...\n" if $VERBOSE;
624		967
625	# four png crunchers work fine for my 2x smp machine	968	# eight png crunchers work fine for my 4x smp machine
626	my @a_png = map +(async \&process_png), 1..4;	969	my @a_png = map +(async \&process_png), 1..8;
627		970
628	$_->join for (@a_trs, @a_res, @a_png);	971	$_->join for @a_any;
		972	print "finished any processing...\n" if $VERBOSE;
		973
		974	$_->join for @a_png;
		975	print "finished png processing...\n" if $VERBOSE;
629		976
630	print "scanning done, processing results...\n" if $VERBOSE;	977	print "scanning done, processing results...\n" if $VERBOSE;
631	{	978	{
632	# remove path prefix from editor_folder	979	# remove path prefix from editor_folder
		980	$_->{editor_folder} =~ /^\x00/
633	substr $_->{editor_folder}, 0, 1 + length $path, ""	981	and substr $_->{editor_folder}, 0, 2 + length $path, ""
634	for values %ARC;	982	for values %ARC;
635		983
636	print "resolving inheritance tree...\n" if $VERBOSE;	984	print "resolving inheritance tree...\n" if $VERBOSE;
637	# resolve inherit	985	# resolve inherit
638	while () {	986	while () {
639	my $progress;	987	my $progress;
640	my $loop;	988	my $loop;
641		989
642	for my $o (values %ARC) {	990	for my $o (values %ARC) {
643	if (my $other = $o->{inherit}) {	991	for my $other (split /,/, $o->{inherit}) {
644	if (my $s = $ARC{$other}) {	992	if (my $s = $ARC{$other}) {
645	if ($s->{inherit}) {	993	if ($s->{inherit}) {
646	$loop = $s;	994	$loop = $s;
647	} else {	995	} else {
648	delete $o->{inherit};	996	delete $o->{inherit};
…		…
650	delete @s{qw(_name more name name_pl)};	998	delete @s{qw(_name more name name_pl)};
651	%$o = ( %s, %$o );	999	%$o = ( %s, %$o );
652	++$progress;	1000	++$progress;
653	}	1001	}
654	} else {	1002	} else {
655	warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";	1003	warn "ERROR: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
656	delete $ARC{$o->{_name}};	1004	delete $ARC{$o->{_name}};
657	}	1005	}
658	}	1006	}
659	}	1007	}
660		1008
…		…
667	}	1015	}
668		1016
669	# remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit	1017	# remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
670	@ARC = grep $_->{_name} !~ /^(?:type\|class)_/, @ARC;	1018	@ARC = grep $_->{_name} !~ /^(?:type\|class)_/, @ARC;
671		1019
		1020	# fix up archetypes without names, where the archanme doesn't work at all
		1021	for (@ARC) {
		1022	if (!exists $_->{name} and $_->{_name} =~ /_/) {
		1023	for ($_->{name} = $_->{_name}) {
		1024	s/(?:_\d+)+$//;
		1025	s/_[nesw]+$//;
		1026	y/_/ /;
		1027	}
		1028	}
		1029	}
		1030
		1031	#print "generating plurals...\n" if $VERBOSE;
		1032	#generate_plurals;
		1033
672	print "writing archetypes...\n" if $VERBOSE;	1034	printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
673	open my $fh, ">:utf8", "$DATADIR/archetypes~"	1035	open my $fh, ">:utf8", "$DATADIR/archetypes~"
674	or die "$DATADIR/archetypes~: $!";	1036	or die "$DATADIR/archetypes~: $!";
675	print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];	1037	print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
676	}	1038	}
677		1039
678	{	1040	{
679	print "writing treasures...\n" if $VERBOSE;	1041	printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
680	open my $fh, ">:utf8", "$DATADIR/treasures~"	1042	open my $fh, ">:utf8", "$DATADIR/treasures~"
681	or die "$DATADIR/treasures~: $!";	1043	or die "$DATADIR/treasures~: $!";
682	print $fh $TRS;	1044	print $fh $TRS;
683	}	1045	}
684		1046
685	{	1047	{
686	print "processing facedata...\n" if $VERBOSE;	1048	print "processing facedata...\n" if $VERBOSE;
687	while (my ($k, $v) = each %FACEINFO) {
688	length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
689	length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
690
691	length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";
692	#length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
693
694	if (my $magicmap = $v->{magicmap}) {
695	$magicmap =~ y/A-Z_\-/a-z/d;
696	$v->{magicmap} = $COLOR{$magicmap};
697	}
698
699	delete $v->{arc};
700	}	1049
		1050	for my $k (sort keys %FACEINFO) {
		1051	my $v = $FACEINFO{$k};
701		1052
		1053	length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
		1054	length $v->{data64} or warn "ERROR: face '$k' has no png64 - this will not work.\n";
		1055
		1056	make_hash $k, $v->{data32}, $v->{hash32};
		1057	make_hash $k, $v->{data64}, $v->{hash64};
		1058
		1059	#length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
		1060	#length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
		1061
		1062	$v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
		1063	$v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
		1064	$v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
		1065
		1066	if (0 && $v->{w} == 1 && $v->{h} == 1) { # texture catalogs
		1067	my $id = @TC;
		1068	my $n = @{ $TC[-1] };
		1069	my $x = $n % TC_W;
		1070	my $y = int $n / TC_W;
		1071
		1072	push @{ $TC[-1] }, [$v, $x, $y];
		1073
		1074	$v->{tc} = [$id, $x, $y];
		1075
		1076	push @TC, [] if $n == TC_W * TC_H - 1; # start new texture if full
		1077	}
		1078
		1079	delete @$v{qw(w h arc stem derive)}; # not used by the server
		1080	}
		1081
		1082	if (0) { #d# texture catalogs
		1083	print "creating texture catalogs...\n" if $VERBOSE;
		1084
		1085	for my $id (0 .. $#TC) {
		1086	my $tc = $TC[$id];
		1087
		1088	my $cmd = "$CONVERT -depth 8 -size " . (TC_W * 64) . "x" . (TC_H * 64) . " xc:transparent";
		1089	my $idx = "a";
		1090
		1091	for (@$tc) {
		1092	my $path = "$TMPDIR/tc" . $idx++;
		1093
		1094	open my $fh, ">:perlio", $path
		1095	or die "$path: $!";
		1096	syswrite $fh, $_->[0]{data64};
		1097
		1098	my $x = $_->[1] * 64;
		1099	my $y = $_->[2] * 64;
		1100
		1101	$cmd .= " png:\Q$path\E -geometry +$x+$y -composite";
		1102	}
		1103
		1104	system "$cmd png:\Q$TMPDIR/tc$id\E";
		1105	optipng "$TMPDIR/tc$id";
		1106	}
		1107	}
		1108
		1109	print "processing resources...\n" if $VERBOSE;
		1110	my $enc = JSON::XS->new->utf8->canonical->relaxed;
		1111	for my $k (sort keys %RESOURCE) {
		1112	my $v = $RESOURCE{$k};
		1113
		1114	if ($v->{meta} && $v->{meta}{datadir}) {
		1115	delete $RESOURCE{$k};
		1116
		1117	$k =~ s/^res\/// or die "$k: datadir files must be in res/";
		1118
		1119	printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
		1120	open my $fh, ">:raw", "$DATADIR/$k~"
		1121	or die "$DATADIR/$k~: $!";
		1122	syswrite $fh, $v->{data};
		1123	push @COMMIT, $k;
		1124
		1125	} else {
		1126	if ($v->{type} & 1) {
		1127	# prepend meta info
		1128
		1129	my $meta = $enc->encode ({
		1130	name => $k,
		1131	%{ $v->{meta} \|\| {} },
		1132	});
		1133
		1134	$v->{data} = pack "(w/a)", $meta, $v->{data};
		1135	}
		1136
		1137	make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
		1138	}
		1139	}
		1140
702	print "writing facedata...\n" if $VERBOSE;	1141	printf "writing facedata...\n" if $VERBOSE;
		1142
		1143	{
703	open my $fh, ">:perlio", "$DATADIR/facedata~"	1144	open my $fh, ">:perlio", "$DATADIR/facedata~"
704	or die "$DATADIR/facedata~: $!";	1145	or die "$DATADIR/facedata~: $!";
705		1146
		1147	print $fh "FACEDATA";
		1148	my $fofs = 8;
		1149
		1150	my $put = sub {
		1151	my $len = length $_[0];
		1152	my $ofs = $fofs;
		1153
		1154	print $fh $_[0];
		1155	$fofs += $len;
		1156
		1157	($len, $ofs)
		1158	};
		1159
		1160	for (values %FACEINFO) {
		1161	($_->{size32}, $_->{fofs32}) = $put->(delete $_->{data32});
		1162	($_->{size64}, $_->{fofs64}) = $put->(delete $_->{data64});
		1163	}
		1164
		1165	for (values %RESOURCE) {
		1166	($_->{size}, $_->{fofs}) = $put->(delete $_->{data});
		1167	}
		1168
		1169	close $fh;
		1170	}
		1171
		1172	printf "writing faceinfo (%d faces, %d anims, %d resources)...\n",
		1173	scalar keys %FACEINFO,
		1174	scalar keys %ANIMINFO,
		1175	scalar keys %RESOURCE
		1176	if $VERBOSE;
		1177
		1178	open my $fh, ">:perlio", "$DATADIR/faceinfo~"
		1179	or die "$DATADIR/faceinfo~: $!";
		1180
706	print $fh freeze {	1181	print $fh nfreeze {
707	version => 2,	1182	version => 2,
708	faceinfo => \%FACEINFO,	1183	faceinfo => \%FACEINFO,
709	animinfo => \%ANIMINFO,	1184	animinfo => \%ANIMINFO,
710	resource => \%RESOURCE,	1185	resource => \%RESOURCE,
711	};	1186	};
712	}	1187	}
713		1188
714	print "committing files...\n" if $VERBOSE;	1189	print "committing files...\n" if $VERBOSE;
715		1190
716	for (qw(archetypes facedata treasures)) {	1191	for (qw(archetypes faceinfo facedata treasures), @COMMIT) {
717	chmod 0644, "$DATADIR/$_~";	1192	chmod 0644, "$DATADIR/$_~";
718	rename "$DATADIR/$_~", "$DATADIR/$_"	1193	rename "$DATADIR/$_~", "$DATADIR/$_"
719	or die "$DATADIR/$_: $!";	1194	or die "$DATADIR/$_: $!";
720	}	1195	}
721		1196

Diff Legend

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

Comparing deliantra/server/utils/cfutil.in (file contents): Revision 1.61 by root, Thu Aug 30 07:13:17 2007 UTC vs. Revision 1.124 by root, Sun Nov 11 05:53:12 2012 UTC

Diff Legend

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.61 by root, Thu Aug 30 07:13:17 2007 UTC vs.
Revision 1.124 by root, Sun Nov 11 05:53:12 2012 UTC