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

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

Diff Legend

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

Comparing deliantra/server/utils/cfutil.in (file contents): Revision 1.50 by root, Thu Aug 9 22:54:28 2007 UTC vs. Revision 1.119 by root, Wed Jan 4 02:48:57 2012 UTC

Diff Legend

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.50 by root, Thu Aug 9 22:54:28 2007 UTC vs.
Revision 1.119 by root, Wed Jan 4 02:48:57 2012 UTC