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

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

Diff Legend

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

Comparing deliantra/server/utils/cfutil.in (file contents): Revision 1.70 by root, Fri Dec 5 00:52:44 2008 UTC vs. Revision 1.126 by root, Wed Jan 11 11:39:02 2017 UTC

Diff Legend

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.70 by root, Fri Dec 5 00:52:44 2008 UTC vs.
Revision 1.126 by root, Wed Jan 11 11:39:02 2017 UTC