ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/utils/cfutil.in
(Generate patch)

Comparing deliantra/server/utils/cfutil.in (file contents):
Revision 1.105 by root, Sun Oct 17 08:00:09 2010 UTC vs.
Revision 1.124 by root, Sun Nov 11 05:53:12 2012 UTC

1#!@PERL@ 1#!@PERL@
2 2
3# 3#
4# This file is part of Deliantra, the Roguelike Realtime MMORPG. 4# This file is part of Deliantra, the Roguelike Realtime MMORPG.
5# 5#
6# Copyright (©) 2007,2008,2009 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 6# Copyright (©) 2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
7# 7#
8# Deliantra is free software: you can redistribute it and/or modify it under 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 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 10# Free Software Foundation, either version 3 of the License, or (at your
11# option) any later version. 11# option) any later version.
12# 12#
13# This program is distributed in the hope that it will be useful, 13# This program is distributed in the hope that it will be useful,
14# but WITHOUT ANY WARRANTY; without even the implied warranty of 14# but WITHOUT ANY WARRANTY; without even the implied warranty of
15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16# GNU General Public License for more details. 16# GNU General Public License for more details.
17# 17#
18# You should have received a copy of the Affero GNU General Public License 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 19# and the GNU General Public License along with this program. If not, see
20# <http://www.gnu.org/licenses/>. 20# <http://www.gnu.org/licenses/>.
21# 21#
22# The authors can be reached via e-mail to <support@deliantra.net> 22# The authors can be reached via e-mail to <support@deliantra.net>
23# 23#
24 24
25use common::sense; 25use common::sense;
26 26
… …
28my $exec_prefix = "@exec_prefix@"; 28my $exec_prefix = "@exec_prefix@";
29my $datarootdir = "@datarootdir@"; 29my $datarootdir = "@datarootdir@";
30my $DATADIR = "@datadir@/@PACKAGE@"; 30my $DATADIR = "@datadir@/@PACKAGE@";
31 31
32my $CONVERT = "@CONVERT@"; 32my $CONVERT = "@CONVERT@";
33#my $IDENTIFY = "@IDENTIFY@"; 33my $IDENTIFY = "@IDENTIFY@";
34my $OPTIPNG = "@OPTIPNG@"; 34my $OPTIPNG = "@OPTIPNG@";
35my $RSYNC = "@RSYNC@"; 35my $RSYNC = "@RSYNC@";
36my $PNGNQ = "@PNGNQ@"; 36my $PNGNQ = "@PNGNQ@";
37 37
38use Getopt::Long; 38use Getopt::Long;
39use File::Temp; 39use File::Temp;
40use POSIX (); 40use POSIX ();
41use Carp; 41use Carp;
42 42
43use Coro::EV;
44use AnyEvent;
45use YAML::XS (); 43use YAML::XS ();
44use Digest::MD5 ();
45use Storable ();
46use JSON::XS (); 46use JSON::XS ();
47use IO::AIO (); 47use IO::AIO ();
48use Digest::MD5 (); 48use Compress::LZF ();
49 49
50use AnyEvent;
50use Coro 5.12; 51use Coro 5.12;
52use Coro::EV;
51use Coro::AIO; 53use Coro::AIO;
52use Coro::Util; 54use Coro::Util;
53use Coro::Channel; 55use Coro::Channel;
56use Coro::AnyEvent;
54use Coro::Storable; $Storable::canonical = 1; 57use Coro::Storable; $Storable::canonical = 1;
55 58
56use Deliantra; 59use Deliantra;
57 60
58$SIG{QUIT} = sub { Carp::cluck "QUIT" }; 61$SIG{QUIT} = sub { Carp::cluck "QUIT" };
59
60sub WRITE_FACEINFO() { 0 }
61 62
62sub usage { 63sub usage {
63 warn <<EOF; 64 warn <<EOF;
64Usage: cfutil [-v] [-q] [--force] [--cache] 65Usage: cfutil [-v] [-q] [--force] [--cache]
65 [--install-arch path] 66 [--install-arch path]
… …
106 khaki => 12, 107 khaki => 12,
107); 108);
108 109
109END { system "rm", "-rf", $TMPDIR } 110END { system "rm", "-rf", $TMPDIR }
110 111
111my $s_INT = EV::signal INT => sub { exit 1 }; 112my $s_INT = AE::signal INT => sub { exit 1 };
112my $s_TERM = EV::signal TERM => sub { exit 1 }; 113my $s_TERM = AE::signal TERM => sub { exit 1 };
113 114
114our %hash; 115our %hash;
115 116
116# here we could try to avoid collisions and reduce chksum size further 117# here we could try to avoid collisions and reduce chksum size further
117sub make_hash($\$\$;$) { 118sub make_hash($\$\$;$) {
118 my ($id, $dataref, $hashref, $clen) = @_; 119 my ($id, $dataref, $hashref, $clen) = @_;
119 120
120 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 4; 121 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 5;
121 122
122 if (exists $hash{$hash}) { 123 if (exists $hash{$hash}) {
123 # hash collision, but some files are simply identical 124 # hash collision, but some files are simply identical
124 if (${$hash{$hash}[1]} ne $$dataref) { 125 if (${$hash{$hash}[1]} ne $$dataref) {
125 warn "hash collision $hash{$hash}[0] vs. $id\n"; 126 warn "ERROR: hash collision $hash{$hash}[0] vs. $id (increase the default \$clen in make_hash?)\n";
126 exit 1; 127 exit 1;
127 } else { 128 } else {
128 print "$hash{$hash}[0] and $id are identical (which is fine).\n" if $VERBOSE >= 3; 129 print "$hash{$hash}[0] and $id are identical (which is fine).\n" if $VERBOSE >= 3;
129 } 130 }
130 } 131 }
131 $hash{$hash} = [$id, $dataref, $hashref]; 132 $hash{$hash} = [$id, $dataref, $hashref];
132 133
133 $$hashref = $hash; 134 $$hashref = $hash;
134} 135}
135 136
137sub optipng($) {
138 system $OPTIPNG, "-o5", "-i0", "-q", $_[0];
139 die "$_[0] has zero size, aborting." unless -s $_[0];
140}
141
136mkdir $TMPDIR, 0700 142mkdir $TMPDIR, 0700
137 or die "$TMPDIR: $!"; 143 or die "$TMPDIR: $!";
138 144
139sub fork_sub(&) { 145sub fork_exec(&) {
140 my ($cb) = @_; 146 my ($cb) = @_;
141 147
142 if (my $pid = fork) { 148 if (my $pid = fork) {
143 my $current = $Coro::current; 149 my $current = $Coro::current;
144 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); 150 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
… …
149 warn $@; 155 warn $@;
150 POSIX::_exit 1; 156 POSIX::_exit 1;
151 } 157 }
152} 158}
153 159
160sub 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
172sub 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
154sub inst_maps($) { 189sub inst_maps($) {
155 my (undef, $path) = @_; 190 my (undef, $path) = @_;
156 191
157 print "\nInstalling '$path' to '$DATADIR/maps'\n\n"; 192 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
158 193
159 if (!-f "$path/regions") { 194 if (!-f "$path/regions") {
160 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";
161 exit 1 unless $FORCE; 196 exit 1 unless $FORCE;
162 } 197 }
163 198
164 system $RSYNC, "-av", "--chmod=u=rwX,go=rX", 199 system $RSYNC, "-av", "--chmod=u=rwX,go=rX",
165 "$path/.", "$DATADIR/maps/.", 200 "$path/.", "$DATADIR/maps/.",
166 "--exclude", "CVS", "--exclude", "/world-precomposed", 201 "--exclude", "CVS", "--exclude", "/world-precomposed",
167 "--delete", "--delete-excluded" 202 "--delete", "--delete-excluded"
168 and die "map installation failed.\n"; 203 and die "map installation failed.\n";
169 204
170 print "maps installed successfully.\n"; 205 print "maps installed successfully.\n";
171}
172
173{
174 no utf8; # == values are utf-8 encoded
175
176 our @WALL_SUFFIX = qw(⬤ ╹ ╺ ┗ ╻ ┃ ┏ ┣ ╸ ┛ ━ ┻ ┓ ┫ ┳ ╋);
177
178 # used to create crude text glyphs for text-based clients
179 sub autoglyph {
180 my ($stem, $face) = @_;
181
182 if ($stem =~ /^wall\/|Nimwall/) {
183 return $WALL_SUFFIX[hex $1]
184 if $stem =~ /(_[0-9A-F]).x11/;
185
186 "█"
187
188 } elsif ($stem =~ /^traps\//) {
189 "☠"
190
191 } elsif ($stem =~ /^armour\/shield/) {
192 "Ø"
193
194 } elsif ($stem =~ /^armour\//) {
195 "A"
196
197 } elsif ($stem =~ /^weapon\//) {
198 "†"
199
200 } elsif ($stem =~ /^readable\//) {
201 "✉"
202
203 } elsif ($stem =~ /^river\//) {
204 "~"
205
206 } elsif ($stem =~ /^floor\/|^ground\/|Nimfloor/) {
207 "·"
208
209 } elsif ($stem =~ /^spells\//) {
210 "!"
211
212 } elsif ($stem =~ /^exit\//) {
213 "⎆"
214
215 } elsif ($stem =~ /^construct\//) {
216 "⌂"
217
218 } elsif ($stem =~ /^player\//) {
219 "\@"
220
221 } elsif ($stem =~ /^(?:monster|misc|class|connect|gods|indoor|inorganic|mining|music|skills).*\/(.)/) {
222 $1
223
224 } else {
225 substr $stem, 0, 1
226 }
227 }
228} 206}
229 207
230{ 208{
231 our %ANIMINFO; 209 our %ANIMINFO;
232 our %FACEINFO; 210 our %FACEINFO;
233 our %RESOURCE; 211 our %RESOURCE;
234 our @ARC; 212 our @ARC;
235 our %ARC; 213 our %ARC;
236 our $TRS; 214 our $TRS;
215 our %PNG;
237 our $NFILE; 216 our $NFILE;
238 our $PATH; 217 our $PATH;
239 218
240 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 219 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
241 220
242 our $c_arc = new Coro::Channel; 221 our $c_arc = new Coro::Channel;
243 our $c_any = new Coro::Channel; 222 our $c_any = new Coro::Channel;
244 223
245 our @c_png; 224 our @c_png;
246 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
247 sub commit_png($$$$) { 232 sub commit_png($$$$$$) {
248 my ($stem, $name, $data, $T) = @_; 233 my ($stem, $name, $data, $T, $w, $h) = @_;
249 234
250 $FACEINFO{$name}{"stem"} = substr $stem, 1 + length $PATH; 235 $FACEINFO{$name}{stem} = substr $stem, 1 + length $PATH;
251 $FACEINFO{$name}{"data$T"} = $data; 236 $FACEINFO{$name}{"data$T"} = $data;
237 $FACEINFO{$name}{w} = $w;
238 $FACEINFO{$name}{h} = $h;
252 } 239 }
253 240
254 sub process_png { 241 sub process_png {
255 while (@c_png) { 242 while (@c_png) {
256 my ($path, $delete) = @{pop @c_png}; 243 my ($path, $delete) = @{pop @c_png};
… …
258 my $png; 245 my $png;
259 aio_lstat $path; 246 aio_lstat $path;
260 my ($size, $mtime) = (stat _)[7,9]; 247 my ($size, $mtime) = (stat _)[7,9];
261 248
262 if (0 > aio_load $path, $png) { 249 if (0 > aio_load $path, $png) {
263 warn "$path: $!, skipping.\n"; 250 warn "ERROR: $path: $!, skipping.\n";
264 next; 251 next;
265 } 252 }
266 253
267 my $stem = $path; 254 my $stem = $path;
268 my $T; 255 my $T;
… …
270 if ($stem =~ s/\.32x32\.png~?$//) { 257 if ($stem =~ s/\.32x32\.png~?$//) {
271 $T = 32; 258 $T = 32;
272 } elsif ($stem =~ s/\.64x64\.png~?$//) { 259 } elsif ($stem =~ s/\.64x64\.png~?$//) {
273 $T = 64; 260 $T = 64;
274 } else { 261 } else {
275 warn "$path: weird filename, skipping.\n"; 262 warn "ERROR: $path: weird filename, skipping.\n";
276 next; 263 next;
277 } 264 }
278 265
279 # quickly extract width and height of the (necessarily PNG) image 266 # quickly extract width and height of the (necessarily PNG) image
280 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) { 267 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
281 warn "$path: not a recognized png file, skipping.\n"; 268 warn "ERROR: $path: not a recognized png file, skipping.\n";
282 next; 269 next;
283 } 270 }
284 271
285 my ($w, $h) = unpack "NN", $1; 272 my ($w, $h) = unpack "NN", $1;
286 273
287 if ($w < $T || $h < $T) { 274 if ($w < $T || $h < $T) {
288 warn "$path: too small ($w $h), skipping.\n"; 275 warn "ERROR: $path: too small ($w $h), skipping.\n";
289 next; 276 next;
290 } 277 }
291 278
292 if ($w % $T || $h % $T) { 279 if ($w % $T || $h % $T) {
293 warn "$path: weird png size ($w $h), skipping.\n"; 280 warn "ERROR: $path: weird png size ($w $h), skipping.\n";
294 next; 281 next;
295 } 282 }
296 283
297 (my $base = $stem) =~ s/^.*\///; 284 (my $base = $stem) =~ s/^.*\///;
298 285
… …
307 unless ($path =~ /~$/) { 294 unless ($path =~ /~$/) {
308 # possibly enlarge 295 # possibly enlarge
309 if (0 > aio_stat "$stem.64x64.png") { 296 if (0 > aio_stat "$stem.64x64.png") {
310 my $other = "$stem.64x64.png~"; 297 my $other = "$stem.64x64.png~";
311 298
312 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 299 make_file $path, $other, sub {
313 fork_sub { 300 fork_exec {
314 my $CROP; 301 my $CROP;
315 my $SRC = "png:\Q$path\E"; 302 my $SRC = "png:\Q$path\E";
316 303
317 my $is_floor = $arc->{is_floor}; 304 my $is_floor = $arc->{is_floor};
318 my $is_wall = 0; 305 my $is_wall = 0;
… …
368 $x * ($w - 8) + 4, 355 $x * ($w - 8) + 4,
369 $y * ($h - 8) + 4; 356 $y * ($h - 8) + 4;
370 } 357 }
371 } 358 }
372 359
373 system "convert -depth 8 $SRC rgba:-" 360 system "$CONVERT -depth 8 $SRC rgba:-"
374 . "| $exec_prefix/bin/cfhq2xa $w $h 0" 361 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
375 . "| 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~"
376 and die "convert/cfhq2xa pipeline error: status $? ($!)"; 363 and die "convert/cfhq2xa pipeline error: status $? ($!)";
377 system $OPTIPNG, "-i0", "-q", "$other~"; 364 optipng "$other~";
378 die "$other~ has zero size, aborting." unless -s "$other~";
379 rename "$other~", $other; 365 rename "$other~", $other;
380 }; 366 };
381 } 367 };
382 368
383 push @c_png, [$other, !$CACHE]; 369 push @c_png, [$other, !$CACHE];
384 } 370 }
385 371
386 # possibly scale down 372 # possibly scale down
387 if (0 > aio_stat "$stem.32x32.png") { 373 if (0 > aio_stat "$stem.32x32.png") {
388 my $other = "$stem.32x32.png~"; 374 my $other = "$stem.32x32.png~";
389 375
390 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 376 make_file $path, $other, sub {
391 fork_sub { 377 fork_exec {
392 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~";
393 system $OPTIPNG, "-i0", "-q", "$other~"; 379 optipng "$other~";
394 380
395 # reduce smoothfaces >10000 bytes 381 # reduce smoothfaces >10000 bytes
396 # obsolete, no longer required 382 # obsolete, no longer required
397 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) { 383 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
398 my $ncolor = 256; 384 my $ncolor = 256;
399 while () { 385 while () {
400 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E"; 386 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
401 system $OPTIPNG, "-i0", "-q", "$other~~"; 387 optipng "$other~~";
402 last if 10000 > -s "$other~~"; 388 last if 10000 > -s "$other~~";
403 $ncolor = int $ncolor * 0.9; 389 $ncolor = int $ncolor * 0.9;
404 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes"; 390 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
405 } 391 }
406 392
… …
411 } 397 }
412 398
413 die "$other~ has zero size, aborting." unless -s "$other~"; 399 die "$other~ has zero size, aborting." unless -s "$other~";
414 rename "$other~", $other; 400 rename "$other~", $other;
415 }; 401 };
416 } 402 };
417 403
418 #warn "scaled down $path to $other\n";#d# 404 #warn "scaled down $path to $other\n";#d#
419 push @c_png, [$other, !$CACHE]; 405 push @c_png, [$other, !$CACHE];
420 } 406 }
421 } 407 }
422 408
423 (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 }
424 460
425 # split all bigfaces, but avoid smoothfaces (*_S) 461 # split all bigfaces, but avoid smoothfaces (*_S)
426 if (($w > $T || $h > $T) && $face !~ /_S\./) { 462 if (($w > $T || $h > $T) && $face !~ /_S\./) {
427 # split 463 # split
428 my @tile; 464 my @tile;
… …
433 push @tile, [$x, $y, $file, (stat _)[9]]; 469 push @tile, [$x, $y, $file, (stat _)[9]];
434 } 470 }
435 } 471 }
436 472
437 my $mtime = (lstat $path)[9]; 473 my $mtime = (lstat $path)[9];
438 my @todo = grep { $_->[3] <= $mtime } @tile; 474 my @todo = grep { $_->[3] < $mtime } @tile;
439 if (@todo) { 475 if (@todo) {
440 fork_sub { 476 fork_exec {
441 open my $convert, "|-", $CONVERT, 477 open my $convert, "|-", $CONVERT,
442 "png:-", 478 "png:-",
443 (map { 479 (map {
444 ( 480 (
445 "(", 481 "(",
… …
458 print $convert $png; 494 print $convert $png;
459 close $convert; 495 close $convert;
460 496
461 # pass 2, optimise, and rename 497 # pass 2, optimise, and rename
462 for (@todo) { 498 for (@todo) {
463 system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~"; 499 optipng "$_->[2]~";
464 die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
465 rename "$_->[2]~", $_->[2]; 500 rename "$_->[2]~", $_->[2];
466 } 501 }
467 }; 502 };
468 } 503 }
469 504
… …
473 508
474 if (0 > aio_load $file, $tile) { 509 if (0 > aio_load $file, $tile) {
475 die "$path: unable to read tile +$x+$y, aborting.\n"; 510 die "$path: unable to read tile +$x+$y, aborting.\n";
476 } 511 }
477 IO::AIO::aio_unlink $file unless $CACHE; 512 IO::AIO::aio_unlink $file unless $CACHE;
478 commit_png $stem, $x|$y ? "$face+$x+$y" : $face, $tile, $T; 513 commit_png $stem, $x|$y ? "$face+$x+$y" : $face, $tile, $T, 1, 1;
479 } 514 }
480 } else { 515 } else {
481 # use as-is (either small, use smooth) 516 # use as-is (either small, use smooth)
482 commit_png $stem, $face, $png, $T; 517 commit_png $stem, $face, $png, $T, $w / $T, $h / $T;
483 } 518 }
484 519
485 aio_unlink $path if $delete; 520 IO::AIO::aio_unlink $path if $delete;
486 } 521 }
487 } 522 }
488 523
489 sub process_faceinfo { 524 sub process_faceinfo {
490 my ($dir, $file) = @_; 525 my ($dir, $file) = @_;
491 my $path = "$dir/$file"; 526 my $path = "$dir/$file";
492 527
493 my $data; 528 my $data;
494 if (0 > aio_load $path, $data) { 529 if (0 > aio_load $path, $data) {
495 warn "$path: $!, skipping.\n"; 530 warn "ERROR: $path: $!, skipping.\n";
496 return; 531 return;
497 } 532 }
498 533
499 for (split /\n/, $data) { 534 for (split /\n/, $data) {
535 chomp;
500 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/; 536 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
537 # bg not used except for text clients
501 538
539 utf8::decode $glyph;
502 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag 540 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag
541 $glyph =~ s/^"(.+)"$/$1/; # allow for ""-style quoting
503 542
504 $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet 543 $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet
505 544
506 (my $fgi = $COLOR{$fg}) 545 (my $fgi = $COLOR{$fg})
507 // warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n"; 546 // warn "ERROR: $path: $face specifies unknown foreground colour '$fg'.\n";
508 (my $bgi = $COLOR{$bg}) 547 (my $bgi = $COLOR{$bg})
509 // warn "WARNING: $path: $face specifies unknown background colour '$bg'.\n"; 548 // warn "ERROR: $path: $face specifies unknown background colour '$bg'.\n";
510 549
511 my $fi = $FACEINFO{$face} ||= { }; 550 my $fi = $FACEINFO{$face} ||= { };
512 $fi->{visibility} = $visibility * 1; 551 $fi->{visibility} = $visibility * 1;
513 $fi->{magicmap} = $fgi; # foreground colour becomes magicmap 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 $_;
514 $fi->{glyph} = (chr $fgi) . (chr $bgi) . $glyph; 560 $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
515 #$fi->{glyph} = (chr $fgi) . $glyph;#d#TOOD remove 561 }
516 # bg not used except for text clients
517 } 562 }
518 } 563 }
519 564
520 sub process_arc { 565 sub process_arc {
521 while (my ($dir, $file) = @{ $c_arc->get }) { 566 while (my ($dir, $file) = @{ $c_arc->get }) {
… …
577 next if /^facings\s/; 622 next if /^facings\s/;
578 623
579 my $face = $_; 624 my $face = $_;
580 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates 625 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
581 626
582 my $info = $FACEINFO{$face} ||= { }; 627 # handle derived faces
628 if ($face =~ /^([^:]+):(.*)/) {
629 my ($type, $base) = ($1, $2);
630 push @{ $FACEINFO{$base}{derive} }, [$dir, $type];
631 }
632
583 $info->{arc} = $o; 633 $FACEINFO{$face}{arc} = $o;
584 634
585 next if $face =~ /^blank.x11$|^empty.x11$/; 635 next if $face =~ /^blank.x11$|^empty.x11$/;
586 } 636 }
587 637
588 if (my $smooth = delete $o->{smoothface}) { 638 if (my $smooth = delete $o->{smoothface}) {
… …
604 my ($dir, $file) = @_; 654 my ($dir, $file) = @_;
605 my $path = "$dir/$file"; 655 my $path = "$dir/$file";
606 656
607 my $trs; 657 my $trs;
608 if (0 > aio_load $path, $trs) { 658 if (0 > aio_load $path, $trs) {
609 warn "$path: $!, skipping.\n"; 659 warn "ERROR: $path: $!, skipping.\n";
610 return; 660 return;
611 } 661 }
612 662
613 $TRS .= $trs; 663 $TRS .= $trs;
614 } 664 }
… …
619 unless (exists $FILECACHE{$_[0]}) { 669 unless (exists $FILECACHE{$_[0]}) {
620 my $data; 670 my $data;
621 if (0 < aio_load $_[0], $data) { 671 if (0 < aio_load $_[0], $data) {
622 if ($_[1]) { 672 if ($_[1]) {
623 $data = eval { $_[1]->($data) }; 673 $data = eval { $_[1]->($data) };
624 warn "$_[0]: $@" if $@; 674 warn "ERROR: $_[0]: $@" if $@;
625 } 675 }
626 } 676 }
627 677
628 $FILECACHE{$_[0]} = $data; 678 $FILECACHE{$_[0]} = $data;
629 } 679 }
630 680
631 $FILECACHE{$_[0]} 681 $FILECACHE{$_[0]}
682 }
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 }
632 } 750 }
633 751
634 sub process_res { 752 sub process_res {
635 my ($dir, $file, $type) = @_; 753 my ($dir, $file, $type) = @_;
636 754
637 my $data;
638 aio_load "$dir/$file", $data; 755 0 <= aio_load "$dir/$file", my $data
756 or die "$dir/$file: $!";
639 757
640 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) }; 758 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
641 759
642 utf8::decode $dir; 760 utf8::decode $dir;
643 utf8::decode $file; 761 utf8::decode $file;
… …
651 $meta = { 769 $meta = {
652 %{ $meta->{"" } || {} }, 770 %{ $meta->{"" } || {} },
653 %{ $meta->{$file} || {} }, 771 %{ $meta->{$file} || {} },
654 }; 772 };
655 773
656 if ($meta->{license} =~ s/^#//) { 774 if (exists $meta->{license} && $meta->{license} =~ s/^#//) { # exists == avoid autovivification
657 $meta->{license} = ({ 775 $meta->{license} = ({
658 "pd" => "Public Domain", 776 "pd" => "Public Domain",
659 "gpl" => "GNU General Public License, version 3.0 or any later", 777 "gpl" => "GNU General Public License, version 3.0 or any later",
660 "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/",
661 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/", 779 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
662 "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/",
663 "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/",
664 })->{$meta->{license}} 782 })->{$meta->{license}}
665 || warn "$dir/$file: license tag '$meta->{license}' not found."; 783 || warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
666 } 784 }
667 785
668 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) { 786 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
669 ($meta->{author} = $1) =~ s/_/ /g; 787 ($meta->{author} = $1) =~ s/_/ /g;
670 } 788 }
671 789
672 $file =~ s/\.res$//; 790 $file =~ s/\.res$//;
673 $file =~ s/\.(ogg|wav|jpg|png)$//; 791 $file =~ s/\.(ogg|wav|jpg|png)$//;
674 792
675 substr $dir, 0, 1 + length $PATH, ""; 793 if ($file =~ s/\.plt$//) {
676 794 $data = process_plt "$dir/$file", $data;
677 if (my $filter = $meta->{cfutil_filter}) { 795 } elsif (my $filter = delete $meta->{cfutil_filter}) {
678 if ($filter eq "yaml2json") { 796 if ($filter eq "yaml2json") {
679 $data = JSON::XS::encode_json YAML::XS::Load $data; 797 $data = JSON::XS::encode_json YAML::XS::Load $data;
680 } elsif ($filter eq "json2json") { 798 } elsif ($filter eq "json2json") {
681 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); 799 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
682 } elsif ($filter eq "perl2json") { 800 } elsif ($filter eq "perl2json") {
683 $data = eval $data; die if $@; 801 $data = eval $data; die if $@;
684 $data = JSON::XS::encode_json $data; 802 $data = JSON::XS::encode_json $data;
685 } else { 803 } else {
686 warn "$dir/$file: unknown filter $filter, skipping\n"; 804 warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
687 }
688 } 805 }
806 }
689 807
690 $RESOURCE{"$dir/$file"} = { 808 substr $dir, 0, 1 + length $PATH, "";
809
810 my %info = (
691 type => (exists $meta->{type} ? delete $meta->{type} : $type), 811 type => (exists $meta->{type} ? delete $meta->{type} : $type),
692 data => $data, 812 data => $data,
693 %$meta ? (meta => $meta) : (), 813 %$meta ? (meta => $meta) : (),
694 }; 814 );
815
816 $RESOURCE{"$dir/$file"} = \%info;
695 } 817 }
696 818
697 sub process_any { 819 sub process_any {
698 while (my ($func, @args) = @{ $c_any->get }) { 820 while (my ($func, @args) = @{ $c_any->get }) {
699 $func->(@args); 821 $func->(@args);
… …
732 if ($file =~ /\.(jpg|png)$/) { 854 if ($file =~ /\.(jpg|png)$/) {
733 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE 855 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
734 } elsif ($file =~ /\.(res)$/) { 856 } elsif ($file =~ /\.(res)$/) {
735 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC 857 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
736 } else { 858 } else {
737 $c_any->put ([\&process_res, $path, $file, undef]); 859 $c_any->put ([\&process_res, $path, $file, 6]); # was type undef, but now meta files are mandatory, so any mentioned file surely has a purpose
738 } 860 }
739 861
740 } elsif ($file =~ /\.png$/) { 862 } elsif ($file =~ /\.png$/) {
741 push @c_png, ["$path/$file", 0]; 863 $PNG{$file} = $path;
742 864
743 } elsif ($file =~ /\.faceinfo$/) { 865 } elsif ($file =~ /\.faceinfo$/) {
744 $c_any->put ([\&process_faceinfo, $path, $file]); 866 $c_any->put ([\&process_faceinfo, $path, $file]);
745 867
746 } elsif ($file =~ /\.trs$/) { 868 } elsif ($file =~ /\.trs$/) {
… …
799 "Unless you run verbosely, all following warning\n", 921 "Unless you run verbosely, all following warning\n",
800 "or error messages indicate serious problems.\n", 922 "or error messages indicate serious problems.\n",
801 "\n"; 923 "\n";
802 924
803 if (!-d "$path/treasures") { 925 if (!-d "$path/treasures") {
804 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 926 warn "FATAL: '$path' does not look like an arch directory ('treasures' directory is missing).\n";
805 exit 1 unless $FORCE; 927 exit 1 unless $FORCE;
806 } 928 }
807 929
808 print "start file scan, arc, any processing...\n" if $VERBOSE; 930 print "starting file scan, arc, any processing...\n" if $VERBOSE;
809 931
810 my @a_arc = map +(async \&process_arc), 1..2; 932 my @a_arc = map +(async \&process_arc), 1..2;
811 my @a_any = map +(async \&process_any), 1..4; 933 my @a_any = map +(async \&process_any), 1..4;
812 934
813 find_files $path; 935 find_files $path;
814 936
815 $c_arc->shutdown; 937 $c_arc->shutdown;
816 $c_any->shutdown; 938 $c_any->shutdown;
817 939
818 $_->join for @a_arc; # need to parse all archetypes before png processing 940 $_->join for @a_arc; # need to parse all archetypes before png processing
941 print "finished arc processing...\n" if $VERBOSE;
819 942
943 # fill png queue
944 for (keys %FACEINFO) {
945 # we only expect source pngs to exist for non-derived
946 # faces, i.e. no split tiles (+x+x) and no face derivates
947 # (xxx:)
948 /^[^:]+\....$/
949 or next;
950
951 my $seen;
952
953 if (exists $PNG{"$_.32x32.png"}) {
954 push @c_png, ["$PNG{\"$_.32x32.png\"}/$_.32x32.png"];
955 $seen = 1;
956 }
957 if (exists $PNG{"$_.64x64.png"}) {
958 push @c_png, ["$PNG{\"$_.64x64.png\"}/$_.64x64.png"];
959 $seen = 1;
960 }
961
962 warn "ERROR: $_: face not found, expect problems.\n"
963 unless $seen;
964 }
965
820 print "end arc, start png processing...\n" if $VERBOSE; 966 print "starting png processing...\n" if $VERBOSE;
821 967
822 # eight png crunchers work fine for my 4x smp machine 968 # eight png crunchers work fine for my 4x smp machine
823 my @a_png = map +(async \&process_png), 1..8; 969 my @a_png = map +(async \&process_png), 1..8;
824 970
825 print "end any processing...\n" if $VERBOSE;
826 $_->join for @a_any; 971 $_->join for @a_any;
827
828 print "end png processing...\n" if $VERBOSE; 972 print "finished any processing...\n" if $VERBOSE;
973
829 $_->join for @a_png; 974 $_->join for @a_png;
975 print "finished png processing...\n" if $VERBOSE;
830 976
831 print "scanning done, processing results...\n" if $VERBOSE; 977 print "scanning done, processing results...\n" if $VERBOSE;
832 { 978 {
833 # remove path prefix from editor_folder 979 # remove path prefix from editor_folder
834 $_->{editor_folder} =~ /^\x00/ 980 $_->{editor_folder} =~ /^\x00/
… …
852 delete @s{qw(_name more name name_pl)}; 998 delete @s{qw(_name more name name_pl)};
853 %$o = ( %s, %$o ); 999 %$o = ( %s, %$o );
854 ++$progress; 1000 ++$progress;
855 } 1001 }
856 } else { 1002 } else {
857 warn "WARNING: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n"; 1003 warn "ERROR: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
858 delete $ARC{$o->{_name}}; 1004 delete $ARC{$o->{_name}};
859 } 1005 }
860 } 1006 }
861 } 1007 }
862 1008
… …
889 open my $fh, ">:utf8", "$DATADIR/archetypes~" 1035 open my $fh, ">:utf8", "$DATADIR/archetypes~"
890 or die "$DATADIR/archetypes~: $!"; 1036 or die "$DATADIR/archetypes~: $!";
891 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC]; 1037 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
892 } 1038 }
893 1039
894 if (WRITE_FACEINFO) {
895 my @table;
896 for my $face (sort keys %FACEINFO) {
897 my $v = $FACEINFO{$face};
898 (my $xf = $face) =~ s/\+\d+\+\d+$//;
899
900 $v->{magicmap} //= $FACEINFO{$xf}{magicmap};
901 $v->{glyph} //= $FACEINFO{$xf}{glyph};
902
903 $v->{magicmap} =~ y/A-Z_\-/a-z/d;
904
905 delete $v->{glyph} if $v->{glyph} =~ /^\?./;
906
907 my $stem = $v->{stem};
908 $v->{glyph} = $v->{glyph} // ("?" . (autoglyph $stem, $v));
909
910 push @table, [$face, $v->{visibility} || 0, $v->{magicmap} || "none", "none ", $v->{glyph}];
911 }
912 use Text::Table;
913 my $tb = new Text::Table undef, { align => "num" }, undef, undef, undef;
914 $tb->load (@table);
915 open my $fh, ">:raw", "default.faceinfo"or die;
916 print $fh $tb;
917 print "default.faceinfo written, exiting.\n";
918 exit 77;
919 }
920
921 { 1040 {
922 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE; 1041 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
923 open my $fh, ">:utf8", "$DATADIR/treasures~" 1042 open my $fh, ">:utf8", "$DATADIR/treasures~"
924 or die "$DATADIR/treasures~: $!"; 1043 or die "$DATADIR/treasures~: $!";
925 print $fh $TRS; 1044 print $fh $TRS;
926 } 1045 }
927 1046
928 { 1047 {
929 print "processing facedata...\n" if $VERBOSE; 1048 print "processing facedata...\n" if $VERBOSE;
930 while (my ($k, $v) = each %FACEINFO) { 1049
1050 for my $k (sort keys %FACEINFO) {
1051 my $v = $FACEINFO{$k};
1052
931 length $v->{data32} or warn "WARNING: face '$k' has no png32. this will not work (shoddy gcfclient will crash of course).\n"; 1053 length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
932 length $v->{data64} or warn "WARNING: face '$k' has no png64. this will not work very well.\n"; 1054 length $v->{data64} or warn "ERROR: face '$k' has no png64 - this will not work.\n";
933 1055
934 make_hash $k, $v->{data32}, $v->{hash32}; 1056 make_hash $k, $v->{data32}, $v->{hash32};
935 make_hash $k, $v->{data64}, $v->{hash64}; 1057 make_hash $k, $v->{data64}, $v->{hash64};
936 1058
937 #length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n"; 1059 #length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
938 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n"; 1060 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
939 1061
940 exists $v->{visibility} 1062 $v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
941 or warn "WARNING: face '$k' has no visibility info, missing faceinfo entry?\n"; 1063 $v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
1064 $v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
942 1065
943 my $stem = delete $v->{stem}; 1066 if (0 && $v->{w} == 1 && $v->{h} == 1) { # texture catalogs
944 $v->{glyph} // warn "WARNING: face '$k' has glyph, cannot autoglyph at the moment."; 1067 my $id = @TC;
945 #$v->{glyph} //= autoglyph $stem, $v; 1068 my $n = @{ $TC[-1] };
1069 my $x = $n % TC_W;
1070 my $y = int $n / TC_W;
946 1071
947 delete $v->{arc}; 1072 push @{ $TC[-1] }, [$v, $x, $y];
1073
1074 $v->{tc} = [$id, $x, $y];
1075
1076 push @TC, [] if $n == TC_W * TC_H - 1; # start new texture if full
948 } 1077 }
1078
1079 delete @$v{qw(w h arc stem derive)}; # not used by the server
1080 }
1081
1082if (0) { #d# texture catalogs
1083 print "creating texture catalogs...\n" if $VERBOSE;
1084
1085 for my $id (0 .. $#TC) {
1086 my $tc = $TC[$id];
1087
1088 my $cmd = "$CONVERT -depth 8 -size " . (TC_W * 64) . "x" . (TC_H * 64) . " xc:transparent";
1089 my $idx = "a";
1090
1091 for (@$tc) {
1092 my $path = "$TMPDIR/tc" . $idx++;
1093
1094 open my $fh, ">:perlio", $path
1095 or die "$path: $!";
1096 syswrite $fh, $_->[0]{data64};
1097
1098 my $x = $_->[1] * 64;
1099 my $y = $_->[2] * 64;
1100
1101 $cmd .= " png:\Q$path\E -geometry +$x+$y -composite";
1102 }
1103
1104 system "$cmd png:\Q$TMPDIR/tc$id\E";
1105 optipng "$TMPDIR/tc$id";
1106 }
1107}
949 1108
950 print "processing resources...\n" if $VERBOSE; 1109 print "processing resources...\n" if $VERBOSE;
951 my $enc = JSON::XS->new->utf8->canonical->relaxed; 1110 my $enc = JSON::XS->new->utf8->canonical->relaxed;
952 while (my ($k, $v) = each %RESOURCE) { 1111 for my $k (sort keys %RESOURCE) {
1112 my $v = $RESOURCE{$k};
953 1113
954 if ($v->{meta} && $v->{meta}{datadir}) { 1114 if ($v->{meta} && $v->{meta}{datadir}) {
955 delete $RESOURCE{$k}; 1115 delete $RESOURCE{$k};
956 1116
957 $k =~ s/^res\/// or die "$k: datadir files must be in res/"; 1117 $k =~ s/^res\/// or die "$k: datadir files must be in res/";
… …
976 1136
977 make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients 1137 make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
978 } 1138 }
979 } 1139 }
980 1140
1141 printf "writing facedata...\n" if $VERBOSE;
1142
1143 {
1144 open my $fh, ">:perlio", "$DATADIR/facedata~"
1145 or die "$DATADIR/facedata~: $!";
1146
1147 print $fh "FACEDATA";
1148 my $fofs = 8;
1149
1150 my $put = sub {
1151 my $len = length $_[0];
1152 my $ofs = $fofs;
1153
1154 print $fh $_[0];
1155 $fofs += $len;
1156
1157 ($len, $ofs)
1158 };
1159
1160 for (values %FACEINFO) {
1161 ($_->{size32}, $_->{fofs32}) = $put->(delete $_->{data32});
1162 ($_->{size64}, $_->{fofs64}) = $put->(delete $_->{data64});
1163 }
1164
1165 for (values %RESOURCE) {
1166 ($_->{size}, $_->{fofs}) = $put->(delete $_->{data});
1167 }
1168
1169 close $fh;
1170 }
1171
981 printf "writing facedata (%d faces, %d anims, %d resources)...\n", 1172 printf "writing faceinfo (%d faces, %d anims, %d resources)...\n",
982 scalar keys %FACEINFO, 1173 scalar keys %FACEINFO,
983 scalar keys %ANIMINFO, 1174 scalar keys %ANIMINFO,
984 scalar keys %RESOURCE 1175 scalar keys %RESOURCE
985 if $VERBOSE; 1176 if $VERBOSE;
986 1177
987 open my $fh, ">:perlio", "$DATADIR/facedata~" 1178 open my $fh, ">:perlio", "$DATADIR/faceinfo~"
988 or die "$DATADIR/facedata~: $!"; 1179 or die "$DATADIR/faceinfo~: $!";
989 1180
990 print $fh nfreeze { 1181 print $fh nfreeze {
991 version => 2, 1182 version => 2,
992 faceinfo => \%FACEINFO, 1183 faceinfo => \%FACEINFO,
993 animinfo => \%ANIMINFO, 1184 animinfo => \%ANIMINFO,
994 resource => \%RESOURCE, 1185 resource => \%RESOURCE,
995 }; 1186 };
996
997 } 1187 }
998 1188
999 print "committing files...\n" if $VERBOSE; 1189 print "committing files...\n" if $VERBOSE;
1000 1190
1001 for (qw(archetypes facedata treasures), @COMMIT) { 1191 for (qw(archetypes faceinfo facedata treasures), @COMMIT) {
1002 chmod 0644, "$DATADIR/$_~"; 1192 chmod 0644, "$DATADIR/$_~";
1003 rename "$DATADIR/$_~", "$DATADIR/$_" 1193 rename "$DATADIR/$_~", "$DATADIR/$_"
1004 or die "$DATADIR/$_: $!"; 1194 or die "$DATADIR/$_: $!";
1005 } 1195 }
1006 1196

Diff Legend

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