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

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.68 by root, Mon Jan 14 10:12:13 2008 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;
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;
		51	use Coro 5.12;
24	use Coro;	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	Event->signal (signal => "INT", cb => sub { exit 1 });	112	my $s_INT = AE::signal INT => sub { exit 1 };
73	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	}
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
130	sub commit_png($$$) {	226	sub commit_png($$$$) {
131	my ($name, $data, $T) = @_;	227	my ($stem, $name, $data, $T) = @_;
132		228
		229	$FACEINFO{$name}{"stem"} = substr $stem, 1 + length $PATH;
133	$FACEINFO{$name}{"data$T"} = $data;	230	$FACEINFO{$name}{"data$T"} = $data;
134	}	231	}
135		232
136	sub process_png {	233	sub process_png {
137	while (@c_png) {	234	while (@c_png) {
…		…
140	my $png;	237	my $png;
141	aio_lstat $path;	238	aio_lstat $path;
142	my ($size, $mtime) = (stat _)[7,9];	239	my ($size, $mtime) = (stat _)[7,9];
143		240
144	if (0 > aio_load $path, $png) {	241	if (0 > aio_load $path, $png) {
145	warn "$path: $!, skipping.\n";	242	warn "ERROR: $path: $!, skipping.\n";
146	next;	243	next;
147	}	244	}
148		245
149	my $stem = $path;	246	my $stem = $path;
150	my $T;	247	my $T;
…		…
152	if ($stem =~ s/\.32x32\.png~?$//) {	249	if ($stem =~ s/\.32x32\.png~?$//) {
153	$T = 32;	250	$T = 32;
154	} elsif ($stem =~ s/\.64x64\.png~?$//) {	251	} elsif ($stem =~ s/\.64x64\.png~?$//) {
155	$T = 64;	252	$T = 64;
156	} else {	253	} else {
157	warn "$path: weird filename, skipping.\n";	254	warn "ERROR: $path: weird filename, skipping.\n";
158	next;	255	next;
159	}	256	}
160		257
161	# quickly extract width and height of the (necessarily PNG) image	258	# quickly extract width and height of the (necessarily PNG) image
162	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {	259	unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
163	warn "$path: not a recognized png file, skipping.\n";	260	warn "ERROR: $path: not a recognized png file, skipping.\n";
164	next;	261	next;
165	}	262	}
166		263
167	my ($w, $h) = unpack "NN", $1;	264	my ($w, $h) = unpack "NN", $1;
168		265
169	if ($w < $T \|\| $h < $T) {	266	if ($w < $T \|\| $h < $T) {
170	warn "$path: too small ($w $h), skipping.\n";	267	warn "ERROR: $path: too small ($w $h), skipping.\n";
171	next;	268	next;
172	}	269	}
173		270
174	if ($w % $T \|\| $h % $T) {	271	if ($w % $T \|\| $h % $T) {
175	warn "$path: weird png size ($w $h), skipping.\n";	272	warn "ERROR: $path: weird png size ($w $h), skipping.\n";
176	next;	273	next;
177	}	274	}
178		275
179	(my $base = $stem) =~ s/^.*\///;	276	(my $base = $stem) =~ s/^.*\///;
180		277
…		…
189	unless ($path =~ /~$/) {	286	unless ($path =~ /~$/) {
190	# possibly enlarge	287	# possibly enlarge
191	if (0 > aio_stat "$stem.64x64.png") {	288	if (0 > aio_stat "$stem.64x64.png") {
192	my $other = "$stem.64x64.png~";	289	my $other = "$stem.64x64.png~";
193		290
194	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	291	make_file $path, $other, sub {
195	fork_sub {	292	fork_exec {
196	my $CROP;	293	my $CROP;
197	my $SRC = "png:\Q$path\E";	294	my $SRC = "png:\Q$path\E";
198		295
199	my $is_floor = $arc->{is_floor};	296	my $is_floor = $arc->{is_floor};
200	my $is_wall = 0;	297	my $is_wall = 0;
…		…
254		351
255	system "convert -depth 8 $SRC rgba:-"	352	system "convert -depth 8 $SRC rgba:-"
256	. "\| $exec_prefix/bin/cfhq2xa $w $h 0"	353	. "\| $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~"	354	. "\| 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 $? ($!)";	355	and die "convert/cfhq2xa pipeline error: status $? ($!)";
259	system $OPTIPNG, "-i0", "-q", "$other~";	356	optipng "$other~";
260	die "$other~ has zero size, aborting." unless -s "$other~";
261	rename "$other~", $other;	357	rename "$other~", $other;
262	};	358	};
263	}	359	};
264		360
265	push @c_png, [$other, !$CACHE];	361	push @c_png, [$other, !$CACHE];
266	}	362	}
267		363
268	# possibly scale down	364	# possibly scale down
269	if (0 > aio_stat "$stem.32x32.png") {	365	if (0 > aio_stat "$stem.32x32.png") {
270	my $other = "$stem.32x32.png~";	366	my $other = "$stem.32x32.png~";
271		367
272	if (0 > aio_lstat $other or (-M _) > (-M $path)) {	368	make_file $path, $other, sub {
273	fork_sub {	369	fork_exec {
274	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~";
275	system $OPTIPNG, "-i0", "-q", "$other~";	371	optipng "$other~";
276		372
277	# reduce smoothfaces >10000 bytes	373	# reduce smoothfaces >10000 bytes
		374	# obsolete, no longer required
278	if ($stem =~ /_S\./ && (-s "$other~") > 10000) {	375	if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
279	my $ncolor = 256;	376	my $ncolor = 256;
280	while () {	377	while () {
281	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";	378	system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
282	system $OPTIPNG, "-i0", "-q", "$other~~";	379	optipng "$other~~";
283	last if 10000 > -s "$other~~";	380	last if 10000 > -s "$other~~";
284	$ncolor = int $ncolor * 0.9;	381	$ncolor = int $ncolor * 0.9;
285	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";	382	$ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
286	}	383	}
287		384
…		…
292	}	389	}
293		390
294	die "$other~ has zero size, aborting." unless -s "$other~";	391	die "$other~ has zero size, aborting." unless -s "$other~";
295	rename "$other~", $other;	392	rename "$other~", $other;
296	};	393	};
297	}	394	};
298		395
299	#warn "scaled down $path to $other\n";#d#	396	#warn "scaled down $path to $other\n";#d#
300	push @c_png, [$other, !$CACHE];	397	push @c_png, [$other, !$CACHE];
301	}	398	}
302	}	399	}
303		400
304	(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	}
305		452
306	# split all bigfaces, but avoid smoothfaces (*_S)	453	# split all bigfaces, but avoid smoothfaces (*_S)
307	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {	454	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {
308	# split	455	# split
309	my @tile;	456	my @tile;
…		…
314	push @tile, [$x, $y, $file, (stat _)[9]];	461	push @tile, [$x, $y, $file, (stat _)[9]];
315	}	462	}
316	}	463	}
317		464
318	my $mtime = (lstat $path)[9];	465	my $mtime = (lstat $path)[9];
319	my @todo = grep { $_->[3] <= $mtime } @tile;	466	my @todo = grep { $_->[3] < $mtime } @tile;
320	if (@todo) {	467	if (@todo) {
321	fork_sub {	468	fork_exec {
322	open my $convert, "\|-", $CONVERT,	469	open my $convert, "\|-", $CONVERT,
323	"png:-",	470	"png:-",
324	(map {	471	(map {
325	(	472	(
326	"(",	473	"(",
…		…
339	print $convert $png;	486	print $convert $png;
340	close $convert;	487	close $convert;
341		488
342	# pass 2, optimise, and rename	489	# pass 2, optimise, and rename
343	for (@todo) {	490	for (@todo) {
344	system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";	491	optipng "$_->[2]~";
345	die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
346	rename "$_->[2]~", $_->[2];	492	rename "$_->[2]~", $_->[2];
347	}	493	}
348	};	494	};
349	}	495	}
350		496
…		…
354		500
355	if (0 > aio_load $file, $tile) {	501	if (0 > aio_load $file, $tile) {
356	die "$path: unable to read tile +$x+$y, aborting.\n";	502	die "$path: unable to read tile +$x+$y, aborting.\n";
357	}	503	}
358	IO::AIO::aio_unlink $file unless $CACHE;	504	IO::AIO::aio_unlink $file unless $CACHE;
359	commit_png $x\|$y ? "$face+$x+$y" : $face, $tile, $T;	505	commit_png $stem, $x\|$y ? "$face+$x+$y" : $face, $tile, $T;
360	}	506	}
361	} else {	507	} else {
362	# use as-is (either small, use smooth)	508	# use as-is (either small, use smooth)
363	commit_png $face, $png, $T;	509	commit_png $stem, $face, $png, $T;
364	}	510	}
365		511
366	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	}
367	}	554	}
368	}	555	}
369		556
370	sub process_arc {	557	sub process_arc {
371	while (my $job = $c_arc->get) {	558	while (my ($dir, $file) = @{ $c_arc->get }) {
372	my ($dir, $file) = @$job;
373
374	my $arc;	559	my $arc;
375	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 :/
376		561
377	my $arc = read_arch "$dir/$file";	562	my $arc = read_arch "$dir/$file";
378	for my $o (values %$arc) {	563	for my $o (values %$arc) {
379	push @ARC, $o;	564	push @ARC, $o;
380	for (my $m = $o; $m; $m = $m->{more}) {	565	for (my $m = $o; $m; $m = $m->{more}) {
381	$ARC{$m->{_name}} = $m;	566	$ARC{$m->{_name}} = $m;
382	}	567	}
383		568
384	$o->{editor_folder} = $dir;	569	$o->{editor_folder} \|\|= "\x00$dir"; # horrible kludge
385
386	my $visibility = delete $o->{visibility};
387	my $magicmap = delete $o->{magicmap};
388		570
389	# find upper left corner :/	571	# find upper left corner :/
390	# omg, this is sooo broken	572	# omg, this is sooo broken
391	my ($dx, $dy);	573	my ($dx, $dy);
392	for (my $o = $o; $o; $o = $o->{more}) {	574	for (my $o = $o; $o; $o = $o->{more}) {
…		…
399	my $y = $o->{y} - $dy;	581	my $y = $o->{y} - $dy;
400		582
401	my $ext = $x\|$y ? "+$x+$y" : "";	583	my $ext = $x\|$y ? "+$x+$y" : "";
402		584
403	$o->{face} .= $ext unless /^blank.x11$\|^empty.x11$/ \|\| !$o->{face};	585	$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		586
408	my $anim = delete $o->{anim};	587	my $anim = delete $o->{anim};
409		588
410	if ($anim) {	589	if ($anim) {
411	# possibly add $ext to the animation name to avoid	590	# possibly add $ext to the animation name to avoid
…		…
435	next if /^facings\s/;	614	next if /^facings\s/;
436		615
437	my $face = $_;	616	my $face = $_;
438	$face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates	617	$face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
439		618
440	my $info = $FACEINFO{$face} \|\|= { };	619	# handle derived faces
		620	if ($face =~ /^([^:]+):(.*)/) {
		621	my ($type, $base) = ($1, $2);
		622	push @{ $FACEINFO{$base}{derive} }, [$dir, $type];
		623	}
		624
441	$info->{arc} = $o;	625	$FACEINFO{$face}{arc} = $o;
442		626
443	next if $face =~ /^blank.x11$\|^empty.x11$/;	627	next if $face =~ /^blank.x11$\|^empty.x11$/;
444
445	$info->{visibility} = $visibility if defined $visibility;
446	$info->{magicmap} = $magicmap if defined $magicmap;
447	}	628	}
448		629
449	if (my $smooth = delete $o->{smoothface}) {	630	if (my $smooth = delete $o->{smoothface}) {
450	my %kv = split /\s+/, $smooth;	631	my %kv = split /\s+/, $smooth;
451	my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support	632	my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
…		…
460	}	641	}
461	}	642	}
462	}	643	}
463		644
464	sub process_trs {	645	sub process_trs {
465	while (my $job = $c_trs->get) {
466	my ($dir, $file) = @$job;	646	my ($dir, $file) = @_;
467	my $path = "$dir/$file";	647	my $path = "$dir/$file";
468		648
469	my $trs;	649	my $trs;
470	if (0 > aio_load $path, $trs) {	650	if (0 > aio_load $path, $trs) {
471	warn "$path: $!, skipping.\n";	651	warn "ERROR: $path: $!, skipping.\n";
472	next;	652	return;
473	}	653	}
474		654
475	$TRS .= $trs;	655	$TRS .= $trs;
476	}
477	}	656	}
478		657
479	my %FILECACHE;	658	my %FILECACHE;
480		659
481	sub load_cached($;$) {	660	sub load_cached($;$) {
482	unless (exists $FILECACHE{$_[0]}) {	661	unless (exists $FILECACHE{$_[0]}) {
483	my $data;	662	my $data;
484	if (0 < aio_load $_[0], $data) {	663	if (0 < aio_load $_[0], $data) {
485	if ($_[1]) {	664	if ($_[1]) {
486	$data = eval { $_[1]->($data) };	665	$data = eval { $_[1]->($data) };
487	warn "$_[0]: $@" if $@;	666	warn "ERROR: $_[0]: $@" if $@;
488	}	667	}
489	}	668	}
490		669
491	$FILECACHE{$_[0]} = $data;	670	$FILECACHE{$_[0]} = $data;
492	}	671	}
493		672
494	$FILECACHE{$_[0]}	673	$FILECACHE{$_[0]}
495	}	674	}
496		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
497	sub process_res {	744	sub process_res {
498	while (my $job = $c_res->get) {
499	my ($dir, $file, $type) = @$job;	745	my ($dir, $file, $type) = @_;
500		746
501	my $data;
502	aio_load "$dir/$file", $data;	747	0 <= aio_load "$dir/$file", my $data
		748	or die "$dir/$file: $!";
503		749
504	my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };	750	my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
505		751
506	utf8::decode $dir;	752	utf8::decode $dir;
507	utf8::decode $file;	753	utf8::decode $file;
508		754
509	# a meta file for resources is now mandatory	755	# a meta file for resources is now mandatory
510	unless (exists $meta->{$file}) {	756	unless (exists $meta->{$file}) {
511	warn "skipping $dir/$file\n" if $VERBOSE >= 3;	757	warn "skipping $dir/$file\n" if $VERBOSE >= 3;
512	next;	758	return;
513	}	759	}
514		760
515	$meta = {	761	$meta = {
516	%{ $meta->{"" } \|\| {} },	762	%{ $meta->{"" } \|\| {} },
517	%{ $meta->{$file} \|\| {} },	763	%{ $meta->{$file} \|\| {} },
518	};	764	};
519		765
520	if ($meta->{license} =~ s/^#//) {	766	if ($meta->{license} =~ s/^#//) {
521	$meta->{license} = ({	767	$meta->{license} = ({
522	"pd" => "Public Domain",	768	"pd" => "Public Domain",
523	"gpl" => "GNU General Public License, version 3.0 or any later",	769	"gpl" => "GNU General Public License, version 3.0 or any later",
524	"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/",
525	"cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 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/",
526	"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/",
527	})->{$meta->{license}}	774	})->{$meta->{license}}
528	\|\| warn "$dir/$file: license tag '$meta->{license}' not found.";	775	\|\| warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
529	}	776	}
530		777
		778	if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
		779	($meta->{author} = $1) =~ s/_/ /g;
		780	}
		781
531	$file =~ s/\.res$//;	782	$file =~ s/\.res$//;
532	$file =~ s/\.(ogg\|wav\|jpg\|png)$//;	783	$file =~ s/\.(ogg\|wav\|jpg\|png)$//;
533		784
534	substr $dir, 0, 1 + length $PATH, "";	785	if ($file =~ s/\.plt$//) {
535		786	$data = process_plt "$dir/$file", $data;
536	if (my $filter = $meta->{cfutil_filter}) {	787	} elsif (my $filter = delete $meta->{cfutil_filter}) {
537	if ($filter eq "yaml2json") {	788	if ($filter eq "yaml2json") {
538	$data = JSON::XS::encode_json YAML::Load $data;	789	$data = JSON::XS::encode_json YAML::XS::Load $data;
539	} elsif ($filter eq "json2json") {	790	} elsif ($filter eq "json2json") {
540	$data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);	791	$data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
541	} elsif ($filter eq "perl2json") {	792	} elsif ($filter eq "perl2json") {
542	$data = eval $data; die if $@;	793	$data = eval $data; die if $@;
543	$data = JSON::XS::encode_json $data;	794	$data = JSON::XS::encode_json $data;
544	} else {	795	} else {
545	warn "$dir/$file: unknown filter $filter, skipping\n";	796	warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
546	}	797	}
547	}	798	}
548		799
		800	substr $dir, 0, 1 + length $PATH, "";
		801
549	$RESOURCE{"$dir/$file"} = {	802	$RESOURCE{"$dir/$file"} = {
550	type => (exists $meta->{type} ? delete $meta->{type} : $type),	803	type => (exists $meta->{type} ? delete $meta->{type} : $type),
551	data => $data,	804	data => $data,
552	%$meta ? (meta => $meta) : (),	805	%$meta ? (meta => $meta) : (),
553	};	806	};
		807	}
		808
		809	sub process_any {
		810	while (my ($func, @args) = @{ $c_any->get }) {
		811	$func->(@args);
554	}	812	}
555	}	813	}
556		814
557	sub find_files;	815	sub find_files;
558	sub find_files {	816	sub find_files {
559	my ($path) = @_;	817	my ($path) = @_;
560		818
		819	my $grp = IO::AIO::aio_group;
		820
		821	my $scandir; $scandir = sub {
		822	my ($path) = @_;
		823
561	IO::AIO::aioreq_pri 4;	824	IO::AIO::aioreq_pri 4;
562	IO::AIO::aio_scandir $path, 4, sub {	825	add $grp IO::AIO::aio_scandir $path, 4, sub {
563	my ($dirs, $nondirs) = @_;	826	my ($dirs, $nondirs) = @_;
564		827
565	find_files "$path/$_"	828	$scandir->("$path/$_")
566	for grep $_ !~ /^(?:CVS\|dev)$/, @$dirs;	829	for grep $_ !~ /^(?:CVS\|dev\|\..*)$/, @$dirs;
567		830
568	my $dir = $path;	831	my $dir = $path;
569	substr $dir, 0, 1 + length $PATH, "";	832	substr $dir, 0, 1 + length $PATH, "";
570		833
571	for my $file (@$nondirs) {	834	for my $file (@$nondirs) {
572	if ($dir =~ /^music(?:\/\|$)/) {	835	if ($dir =~ /^music(?:\/\|$)/) {
573	$c_res->put ([$path, $file, 3]) # FT_MUSIC	836	$c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
574	if $file =~ /\.(ogg)$/;	837	if $file =~ /\.(ogg)$/;
575		838
576	} elsif ($dir =~ /^sound(?:\/\|$)/) {	839	} elsif ($dir =~ /^sound(?:\/\|$)/) {
577	$c_res->put ([$path, $file, 5]) # FT_SOUND	840	$c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
578	if $file =~ /\.(wav\|ogg)$/;	841	if $file =~ /\.(wav\|ogg)$/;
579		842
580	} elsif ($dir =~ /^res(?:\/\|$)/) {	843	} elsif ($dir =~ /^res(?:\/\|$)/) {
581	if ($file =~ /\.(jpg\|png)$/) {	844	if ($file =~ /\.(jpg\|png)$/) {
582	$c_res->put ([$path, $file, 0]) # FT_FACE	845	$c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
583	} elsif ($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	}
		851
		852	} elsif ($file =~ /\.png$/) {
		853	$PNG{$file} = $path;
		854
		855	} elsif ($file =~ /\.faceinfo$/) {
		856	$c_any->put ([\&process_faceinfo, $path, $file]);
		857
		858	} elsif ($file =~ /\.trs$/) {
		859	$c_any->put ([\&process_trs, $path, $file]);
		860
		861	} elsif ($file =~ /\.arc$/) {
584	$c_res->put ([$path, $file, 6]) # FT_RSRC	862	$c_arc->put ([$path, $file]);
		863
585	} else {	864	} else {
586	$c_res->put ([$path, $file, undef]);	865	warn "ignoring $path/$file\n" if $VERBOSE >= 3;
587	}	866	}
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 {	867	}
599	warn "ignoring $path/$file\n" if $VERBOSE >= 3;
600	}
601	}	868	};
602	};	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	# }
603	}	898	}
604		899
605	sub inst_arch($) {	900	sub inst_arch($) {
606	my (undef, $path) = @_;	901	my (undef, $path) = @_;
607		902
…		…
616	"Unless you run verbosely, all following warning\n",	911	"Unless you run verbosely, all following warning\n",
617	"or error messages indicate serious problems.\n",	912	"or error messages indicate serious problems.\n",
618	"\n";	913	"\n";
619		914
620	if (!-d "$path/treasures") {	915	if (!-d "$path/treasures") {
621	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";
622	exit 1 unless $FORCE;	917	exit 1 unless $FORCE;
623	}	918	}
624		919
625	print "scanning files...\n" if $VERBOSE;	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;
626		924
627	find_files $path;	925	find_files $path;
628		926
629	my @a_arc = map +(async \&process_arc), 1..2;	927	$c_arc->shutdown;
630	my @a_res = map +(async \&process_res), 1..2;	928	$c_any->shutdown;
631	my @a_trs = map +(async \&process_trs), 1..2;
632
633	IO::AIO::flush;
634
635	$c_res->put (undef) for @a_res;
636	$c_arc->put (undef) for @a_arc;
637	$c_trs->put (undef) for @a_trs;
638
639	print "start file scan, arc, res processing...\n" if $VERBOSE;
640		929
641	$_->join for @a_arc; # need to parse all archetypes before png processing	930	$_->join for @a_arc; # need to parse all archetypes before png processing
		931	print "finished arc processing...\n" if $VERBOSE;
642		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
643	print "end arc, start png processing...\n" if $VERBOSE;	956	print "starting png processing...\n" if $VERBOSE;
644		957
645	# four png crunchers work fine for my 2x smp machine	958	# eight png crunchers work fine for my 4x smp machine
646	my @a_png = map +(async \&process_png), 1..4;	959	my @a_png = map +(async \&process_png), 1..8;
647		960
648	$_->join for (@a_trs, @a_res, @a_png);	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;
649		966
650	print "scanning done, processing results...\n" if $VERBOSE;	967	print "scanning done, processing results...\n" if $VERBOSE;
651	{	968	{
652	# remove path prefix from editor_folder	969	# remove path prefix from editor_folder
		970	$_->{editor_folder} =~ /^\x00/
653	substr $_->{editor_folder}, 0, 1 + length $path, ""	971	and substr $_->{editor_folder}, 0, 2 + length $path, ""
654	for values %ARC;	972	for values %ARC;
655		973
656	print "resolving inheritance tree...\n" if $VERBOSE;	974	print "resolving inheritance tree...\n" if $VERBOSE;
657	# resolve inherit	975	# resolve inherit
658	while () {	976	while () {
659	my $progress;	977	my $progress;
660	my $loop;	978	my $loop;
661		979
662	for my $o (values %ARC) {	980	for my $o (values %ARC) {
663	if (my $other = $o->{inherit}) {	981	for my $other (split /,/, $o->{inherit}) {
664	if (my $s = $ARC{$other}) {	982	if (my $s = $ARC{$other}) {
665	if ($s->{inherit}) {	983	if ($s->{inherit}) {
666	$loop = $s;	984	$loop = $s;
667	} else {	985	} else {
668	delete $o->{inherit};	986	delete $o->{inherit};
…		…
670	delete @s{qw(_name more name name_pl)};	988	delete @s{qw(_name more name name_pl)};
671	%$o = ( %s, %$o );	989	%$o = ( %s, %$o );
672	++$progress;	990	++$progress;
673	}	991	}
674	} else {	992	} else {
675	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";
676	delete $ARC{$o->{_name}};	994	delete $ARC{$o->{_name}};
677	}	995	}
678	}	996	}
679	}	997	}
680		998
…		…
687	}	1005	}
688		1006
689	# 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
690	@ARC = grep $_->{_name} !~ /^(?:type\|class)_/, @ARC;	1008	@ARC = grep $_->{_name} !~ /^(?:type\|class)_/, @ARC;
691		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
692	print "writing archetypes...\n" if $VERBOSE;	1024	printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
693	open my $fh, ">:utf8", "$DATADIR/archetypes~"	1025	open my $fh, ">:utf8", "$DATADIR/archetypes~"
694	or die "$DATADIR/archetypes~: $!";	1026	or die "$DATADIR/archetypes~: $!";
695	print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];	1027	print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
696	}	1028	}
697		1029
698	{	1030	{
699	print "writing treasures...\n" if $VERBOSE;	1031	printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
700	open my $fh, ">:utf8", "$DATADIR/treasures~"	1032	open my $fh, ">:utf8", "$DATADIR/treasures~"
701	or die "$DATADIR/treasures~: $!";	1033	or die "$DATADIR/treasures~: $!";
702	print $fh $TRS;	1034	print $fh $TRS;
703	}	1035	}
704		1036
705	{	1037	{
706	print "processing facedata...\n" if $VERBOSE;	1038	print "processing facedata...\n" if $VERBOSE;
707	while (my ($k, $v) = each %FACEINFO) {	1039	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";	1040	length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
709	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";
710		1042
		1043	make_hash $k, $v->{data32}, $v->{hash32};
		1044	make_hash $k, $v->{data64}, $v->{hash64};
		1045
711	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";
712	#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";
713		1048
714	if (my $magicmap = $v->{magicmap}) {	1049	$v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
715	$magicmap =~ y/A-Z_\-/a-z/d;	1050	$v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
716	$v->{magicmap} = $COLOR{$magicmap};	1051	$v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
		1052
		1053	delete @$v{qw(arc stem derive)}; # not used by the server
		1054	}
		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};
717	}	1081	}
718		1082
719	delete $v->{arc};	1083	make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
720	}	1084	}
		1085	}
721		1086
722	print "writing facedata...\n" if $VERBOSE;	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;
		1092
723	open my $fh, ">:perlio", "$DATADIR/facedata~"	1093	open my $fh, ">:perlio", "$DATADIR/facedata~"
724	or die "$DATADIR/facedata~: $!";	1094	or die "$DATADIR/facedata~: $!";
725		1095
726	print $fh freeze {	1096	print $fh nfreeze {
727	version => 2,	1097	version => 2,
728	faceinfo => \%FACEINFO,	1098	faceinfo => \%FACEINFO,
729	animinfo => \%ANIMINFO,	1099	animinfo => \%ANIMINFO,
730	resource => \%RESOURCE,	1100	resource => \%RESOURCE,
731	};	1101	};
732	}	1102	}
733		1103
734	print "committing files...\n" if $VERBOSE;	1104	print "committing files...\n" if $VERBOSE;
735		1105
736	for (qw(archetypes facedata treasures)) {	1106	for (qw(archetypes facedata treasures), @COMMIT) {
737	chmod 0644, "$DATADIR/$_~";	1107	chmod 0644, "$DATADIR/$_~";
738	rename "$DATADIR/$_~", "$DATADIR/$_"	1108	rename "$DATADIR/$_~", "$DATADIR/$_"
739	or die "$DATADIR/$_: $!";	1109	or die "$DATADIR/$_: $!";
740	}	1110	}
741		1111

Diff Legend

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

Comparing deliantra/server/utils/cfutil.in (file contents): Revision 1.68 by root, Mon Jan 14 10:12:13 2008 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.68 by root, Mon Jan 14 10:12:13 2008 UTC vs.
Revision 1.119 by root, Wed Jan 4 02:48:57 2012 UTC