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

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.54 by root, Sun Aug 19 10:28:52 2007 UTC vs.
Revision 1.121 by root, Mon Oct 29 22:50:10 2012 UTC

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

Diff Legend

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

Comparing deliantra/server/utils/cfutil.in (file contents): Revision 1.54 by root, Sun Aug 19 10:28:52 2007 UTC vs. Revision 1.121 by root, Mon Oct 29 22:50:10 2012 UTC

Diff Legend

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.54 by root, Sun Aug 19 10:28:52 2007 UTC vs.
Revision 1.121 by root, Mon Oct 29 22:50:10 2012 UTC