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.83 by root, Wed Apr 28 20:51:58 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 strict; 25use common::sense;
26 26
27my $prefix = "@prefix@"; 27my $prefix = "@prefix@";
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" };
… …
77my $TMPDIR = "/tmp/cfutil$$~"; 80my $TMPDIR = "/tmp/cfutil$$~";
78my $TMPFILE = "aaaa0"; 81my $TMPFILE = "aaaa0";
79my @COMMIT; 82my @COMMIT;
80 83
81our %COLOR = ( 84our %COLOR = (
85 # original cf colours
82 black => 0, 86 black => 0,
83 white => 1, 87 white => 1,
84 navy => 2, 88 navy => 2, # "dark blue"
85 red => 3, 89 red => 3,
86 orange => 4, 90 orange => 4,
87 blue => 5, 91 blue => 5, # "light blue"
88 darkorange => 6, 92 darkorange => 6,
89 green => 7, 93 green => 7,
90 lightgreen => 8, 94 lightgreen => 8,
91 grey => 9, 95 grey => 9,
96 brown => 10, # "yellow"
97 gold => 11, # "light yellow"
98 tan => 12, # yellowish gray
99
100 # new for deliantra
92 brown => 10, 101 none => 13,
102
103 # compatibility to existing archetypes
104 lightblue => 5,
93 gold => 11, 105 gray => 9,
106 yellow => 11,
94 tan => 12, 107 khaki => 12,
95); 108);
96 109
97END { system "rm", "-rf", $TMPDIR } 110END { system "rm", "-rf", $TMPDIR }
98 111
99my $s_INT = EV::signal INT => sub { exit 1 }; 112my $s_INT = AE::signal INT => sub { exit 1 };
100my $s_TERM = EV::signal TERM => sub { exit 1 }; 113my $s_TERM = AE::signal TERM => sub { exit 1 };
101 114
102our %hash; 115our %hash;
103 116
104# 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
105sub make_hash($\$\$;$) { 118sub make_hash($\$\$;$) {
106 my ($id, $dataref, $hashref, $clen) = @_; 119 my ($id, $dataref, $hashref, $clen) = @_;
107 120
108 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 4; 121 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 5;
109 122
110 if (exists $hash{$hash}) { 123 if (exists $hash{$hash}) {
111 # hahs collinion, but some files are simply identical 124 # hash collision, but some files are simply identical
112 if (${$hash{$hash}[1]} ne $$dataref) { 125 if (${$hash{$hash}[1]} ne $$dataref) {
113 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";
114 exit 1; 127 exit 1;
115 } else { 128 } else {
116 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;
117 } 130 }
118 } 131 }
119 $hash{$hash} = [$id, $dataref, $hashref]; 132 $hash{$hash} = [$id, $dataref, $hashref];
120 133
121 $$hashref = $hash; 134 $$hashref = $hash;
122} 135}
123 136
137sub optipng($) {
138 system $OPTIPNG, "-o5", "-i0", "-q", $_[0];
139 die "$_[0] has zero size, aborting." unless -s $_[0];
140}
141
124mkdir $TMPDIR, 0700 142mkdir $TMPDIR, 0700
125 or die "$TMPDIR: $!"; 143 or die "$TMPDIR: $!";
126 144
127sub fork_sub(&) { 145sub fork_exec(&) {
128 my ($cb) = @_; 146 my ($cb) = @_;
129 147
130 if (my $pid = fork) { 148 if (my $pid = fork) {
131 my $current = $Coro::current; 149 my $current = $Coro::current;
132 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); 150 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
… …
137 warn $@; 155 warn $@;
138 POSIX::_exit 1; 156 POSIX::_exit 1;
139 } 157 }
140} 158}
141 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
142sub inst_maps($) { 189sub inst_maps($) {
143 my (undef, $path) = @_; 190 my (undef, $path) = @_;
144 191
145 print "\nInstalling '$path' to '$DATADIR/maps'\n\n"; 192 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
146 193
147 if (!-f "$path/regions") { 194 if (!-f "$path/regions") {
148 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";
149 exit 1 unless $FORCE; 196 exit 1 unless $FORCE;
150 } 197 }
151 198
152 system $RSYNC, "-av", "--chmod=u=rwX,go=rX", 199 system $RSYNC, "-av", "--chmod=u=rwX,go=rX",
153 "$path/.", "$DATADIR/maps/.", 200 "$path/.", "$DATADIR/maps/.",
… …
163 our %FACEINFO; 210 our %FACEINFO;
164 our %RESOURCE; 211 our %RESOURCE;
165 our @ARC; 212 our @ARC;
166 our %ARC; 213 our %ARC;
167 our $TRS; 214 our $TRS;
215 our %PNG;
168 our $NFILE; 216 our $NFILE;
169 our $PATH; 217 our $PATH;
170 218
171 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 219 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
172 220
173 our $c_arc = new Coro::Channel; 221 our $c_arc = new Coro::Channel;
174 our $c_trs = new Coro::Channel; 222 our $c_any = new Coro::Channel;
175 our $c_res = new Coro::Channel;
176 223
177 our @c_png; 224 our @c_png;
178 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
179 sub commit_png($$$) { 232 sub commit_png($$$$$$) {
180 my ($name, $data, $T) = @_; 233 my ($stem, $name, $data, $T, $w, $h) = @_;
181 234
235 $FACEINFO{$name}{stem} = substr $stem, 1 + length $PATH;
182 $FACEINFO{$name}{"data$T"} = $data; 236 $FACEINFO{$name}{"data$T"} = $data;
237 $FACEINFO{$name}{w} = $w;
238 $FACEINFO{$name}{h} = $h;
183 } 239 }
184 240
185 sub process_png { 241 sub process_png {
186 while (@c_png) { 242 while (@c_png) {
187 my ($path, $delete) = @{pop @c_png}; 243 my ($path, $delete) = @{pop @c_png};
… …
189 my $png; 245 my $png;
190 aio_lstat $path; 246 aio_lstat $path;
191 my ($size, $mtime) = (stat _)[7,9]; 247 my ($size, $mtime) = (stat _)[7,9];
192 248
193 if (0 > aio_load $path, $png) { 249 if (0 > aio_load $path, $png) {
194 warn "$path: $!, skipping.\n"; 250 warn "ERROR: $path: $!, skipping.\n";
195 next; 251 next;
196 } 252 }
197 253
198 my $stem = $path; 254 my $stem = $path;
199 my $T; 255 my $T;
… …
201 if ($stem =~ s/\.32x32\.png~?$//) { 257 if ($stem =~ s/\.32x32\.png~?$//) {
202 $T = 32; 258 $T = 32;
203 } elsif ($stem =~ s/\.64x64\.png~?$//) { 259 } elsif ($stem =~ s/\.64x64\.png~?$//) {
204 $T = 64; 260 $T = 64;
205 } else { 261 } else {
206 warn "$path: weird filename, skipping.\n"; 262 warn "ERROR: $path: weird filename, skipping.\n";
207 next; 263 next;
208 } 264 }
209 265
210 # quickly extract width and height of the (necessarily PNG) image 266 # quickly extract width and height of the (necessarily PNG) image
211 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) { 267 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
212 warn "$path: not a recognized png file, skipping.\n"; 268 warn "ERROR: $path: not a recognized png file, skipping.\n";
213 next; 269 next;
214 } 270 }
215 271
216 my ($w, $h) = unpack "NN", $1; 272 my ($w, $h) = unpack "NN", $1;
217 273
218 if ($w < $T || $h < $T) { 274 if ($w < $T || $h < $T) {
219 warn "$path: too small ($w $h), skipping.\n"; 275 warn "ERROR: $path: too small ($w $h), skipping.\n";
220 next; 276 next;
221 } 277 }
222 278
223 if ($w % $T || $h % $T) { 279 if ($w % $T || $h % $T) {
224 warn "$path: weird png size ($w $h), skipping.\n"; 280 warn "ERROR: $path: weird png size ($w $h), skipping.\n";
225 next; 281 next;
226 } 282 }
227 283
228 (my $base = $stem) =~ s/^.*\///; 284 (my $base = $stem) =~ s/^.*\///;
229 285
… …
238 unless ($path =~ /~$/) { 294 unless ($path =~ /~$/) {
239 # possibly enlarge 295 # possibly enlarge
240 if (0 > aio_stat "$stem.64x64.png") { 296 if (0 > aio_stat "$stem.64x64.png") {
241 my $other = "$stem.64x64.png~"; 297 my $other = "$stem.64x64.png~";
242 298
243 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 299 make_file $path, $other, sub {
244 fork_sub { 300 fork_exec {
245 my $CROP; 301 my $CROP;
246 my $SRC = "png:\Q$path\E"; 302 my $SRC = "png:\Q$path\E";
247 303
248 my $is_floor = $arc->{is_floor}; 304 my $is_floor = $arc->{is_floor};
249 my $is_wall = 0; 305 my $is_wall = 0;
… …
299 $x * ($w - 8) + 4, 355 $x * ($w - 8) + 4,
300 $y * ($h - 8) + 4; 356 $y * ($h - 8) + 4;
301 } 357 }
302 } 358 }
303 359
304 system "convert -depth 8 $SRC rgba:-" 360 system "$CONVERT -depth 8 $SRC rgba:-"
305 . "| $exec_prefix/bin/cfhq2xa $w $h 0" 361 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
306 . "| 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~"
307 and die "convert/cfhq2xa pipeline error: status $? ($!)"; 363 and die "convert/cfhq2xa pipeline error: status $? ($!)";
308 system $OPTIPNG, "-i0", "-q", "$other~"; 364 optipng "$other~";
309 die "$other~ has zero size, aborting." unless -s "$other~";
310 rename "$other~", $other; 365 rename "$other~", $other;
311 }; 366 };
312 } 367 };
313 368
314 push @c_png, [$other, !$CACHE]; 369 push @c_png, [$other, !$CACHE];
315 } 370 }
316 371
317 # possibly scale down 372 # possibly scale down
318 if (0 > aio_stat "$stem.32x32.png") { 373 if (0 > aio_stat "$stem.32x32.png") {
319 my $other = "$stem.32x32.png~"; 374 my $other = "$stem.32x32.png~";
320 375
321 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 376 make_file $path, $other, sub {
322 fork_sub { 377 fork_exec {
323 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~";
324 system $OPTIPNG, "-i0", "-q", "$other~"; 379 optipng "$other~";
325 380
326 # reduce smoothfaces >10000 bytes 381 # reduce smoothfaces >10000 bytes
327 # obsolete, no longer required 382 # obsolete, no longer required
328 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) { 383 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
329 my $ncolor = 256; 384 my $ncolor = 256;
330 while () { 385 while () {
331 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E"; 386 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
332 system $OPTIPNG, "-i0", "-q", "$other~~"; 387 optipng "$other~~";
333 last if 10000 > -s "$other~~"; 388 last if 10000 > -s "$other~~";
334 $ncolor = int $ncolor * 0.9; 389 $ncolor = int $ncolor * 0.9;
335 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes"; 390 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
336 } 391 }
337 392
… …
342 } 397 }
343 398
344 die "$other~ has zero size, aborting." unless -s "$other~"; 399 die "$other~ has zero size, aborting." unless -s "$other~";
345 rename "$other~", $other; 400 rename "$other~", $other;
346 }; 401 };
347 } 402 };
348 403
349 #warn "scaled down $path to $other\n";#d# 404 #warn "scaled down $path to $other\n";#d#
350 push @c_png, [$other, !$CACHE]; 405 push @c_png, [$other, !$CACHE];
351 } 406 }
352 } 407 }
353 408
354 (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 }
355 460
356 # split all bigfaces, but avoid smoothfaces (*_S) 461 # split all bigfaces, but avoid smoothfaces (*_S)
357 if (($w > $T || $h > $T) && $face !~ /_S\./) { 462 if (($w > $T || $h > $T) && $face !~ /_S\./) {
358 # split 463 # split
359 my @tile; 464 my @tile;
… …
364 push @tile, [$x, $y, $file, (stat _)[9]]; 469 push @tile, [$x, $y, $file, (stat _)[9]];
365 } 470 }
366 } 471 }
367 472
368 my $mtime = (lstat $path)[9]; 473 my $mtime = (lstat $path)[9];
369 my @todo = grep { $_->[3] <= $mtime } @tile; 474 my @todo = grep { $_->[3] < $mtime } @tile;
370 if (@todo) { 475 if (@todo) {
371 fork_sub { 476 fork_exec {
372 open my $convert, "|-", $CONVERT, 477 open my $convert, "|-", $CONVERT,
373 "png:-", 478 "png:-",
374 (map { 479 (map {
375 ( 480 (
376 "(", 481 "(",
… …
389 print $convert $png; 494 print $convert $png;
390 close $convert; 495 close $convert;
391 496
392 # pass 2, optimise, and rename 497 # pass 2, optimise, and rename
393 for (@todo) { 498 for (@todo) {
394 system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~"; 499 optipng "$_->[2]~";
395 die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
396 rename "$_->[2]~", $_->[2]; 500 rename "$_->[2]~", $_->[2];
397 } 501 }
398 }; 502 };
399 } 503 }
400 504
… …
404 508
405 if (0 > aio_load $file, $tile) { 509 if (0 > aio_load $file, $tile) {
406 die "$path: unable to read tile +$x+$y, aborting.\n"; 510 die "$path: unable to read tile +$x+$y, aborting.\n";
407 } 511 }
408 IO::AIO::aio_unlink $file unless $CACHE; 512 IO::AIO::aio_unlink $file unless $CACHE;
409 commit_png $x|$y ? "$face+$x+$y" : $face, $tile, $T; 513 commit_png $stem, $x|$y ? "$face+$x+$y" : $face, $tile, $T, 1, 1;
410 } 514 }
411 } else { 515 } else {
412 # use as-is (either small, use smooth) 516 # use as-is (either small, use smooth)
413 commit_png $face, $png, $T; 517 commit_png $stem, $face, $png, $T, $w / $T, $h / $T;
414 } 518 }
415 519
416 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 }
417 } 562 }
418 } 563 }
419 564
420 sub process_arc { 565 sub process_arc {
421 while (my $job = $c_arc->get) { 566 while (my ($dir, $file) = @{ $c_arc->get }) {
422 my ($dir, $file) = @$job;
423
424 my $arc; 567 my $arc;
425 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 :/
426 569
427 my $arc = read_arch "$dir/$file"; 570 my $arc = read_arch "$dir/$file";
428 for my $o (values %$arc) { 571 for my $o (values %$arc) {
… …
430 for (my $m = $o; $m; $m = $m->{more}) { 573 for (my $m = $o; $m; $m = $m->{more}) {
431 $ARC{$m->{_name}} = $m; 574 $ARC{$m->{_name}} = $m;
432 } 575 }
433 576
434 $o->{editor_folder} ||= "\x00$dir"; # horrible kludge 577 $o->{editor_folder} ||= "\x00$dir"; # horrible kludge
435
436 my $visibility = delete $o->{visibility};
437 my $magicmap = delete $o->{magicmap};
438 578
439 # find upper left corner :/ 579 # find upper left corner :/
440 # omg, this is sooo broken 580 # omg, this is sooo broken
441 my ($dx, $dy); 581 my ($dx, $dy);
442 for (my $o = $o; $o; $o = $o->{more}) { 582 for (my $o = $o; $o; $o = $o->{more}) {
… …
449 my $y = $o->{y} - $dy; 589 my $y = $o->{y} - $dy;
450 590
451 my $ext = $x|$y ? "+$x+$y" : ""; 591 my $ext = $x|$y ? "+$x+$y" : "";
452 592
453 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face}; 593 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face};
454
455 $visibility = delete $o->{visibility} if exists $o->{visibility};
456 $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
457 594
458 my $anim = delete $o->{anim}; 595 my $anim = delete $o->{anim};
459 596
460 if ($anim) { 597 if ($anim) {
461 # possibly add $ext to the animation name to avoid 598 # possibly add $ext to the animation name to avoid
… …
485 next if /^facings\s/; 622 next if /^facings\s/;
486 623
487 my $face = $_; 624 my $face = $_;
488 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates 625 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
489 626
490 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
491 $info->{arc} = $o; 633 $FACEINFO{$face}{arc} = $o;
492 634
493 next if $face =~ /^blank.x11$|^empty.x11$/; 635 next if $face =~ /^blank.x11$|^empty.x11$/;
494
495 $info->{visibility} = $visibility if defined $visibility;
496 $info->{magicmap} = $magicmap if defined $magicmap;
497 } 636 }
498 637
499 if (my $smooth = delete $o->{smoothface}) { 638 if (my $smooth = delete $o->{smoothface}) {
500 my %kv = split /\s+/, $smooth; 639 my %kv = split /\s+/, $smooth;
501 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 640 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
… …
510 } 649 }
511 } 650 }
512 } 651 }
513 652
514 sub process_trs { 653 sub process_trs {
515 while (my $job = $c_trs->get) {
516 my ($dir, $file) = @$job; 654 my ($dir, $file) = @_;
517 my $path = "$dir/$file"; 655 my $path = "$dir/$file";
518 656
519 my $trs; 657 my $trs;
520 if (0 > aio_load $path, $trs) { 658 if (0 > aio_load $path, $trs) {
521 warn "$path: $!, skipping.\n"; 659 warn "ERROR: $path: $!, skipping.\n";
522 next; 660 return;
523 } 661 }
524 662
525 $TRS .= $trs; 663 $TRS .= $trs;
526 }
527 } 664 }
528 665
529 my %FILECACHE; 666 my %FILECACHE;
530 667
531 sub load_cached($;$) { 668 sub load_cached($;$) {
532 unless (exists $FILECACHE{$_[0]}) { 669 unless (exists $FILECACHE{$_[0]}) {
533 my $data; 670 my $data;
534 if (0 < aio_load $_[0], $data) { 671 if (0 < aio_load $_[0], $data) {
535 if ($_[1]) { 672 if ($_[1]) {
536 $data = eval { $_[1]->($data) }; 673 $data = eval { $_[1]->($data) };
537 warn "$_[0]: $@" if $@; 674 warn "ERROR: $_[0]: $@" if $@;
538 } 675 }
539 } 676 }
540 677
541 $FILECACHE{$_[0]} = $data; 678 $FILECACHE{$_[0]} = $data;
542 } 679 }
543 680
544 $FILECACHE{$_[0]} 681 $FILECACHE{$_[0]}
545 } 682 }
546 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
547 sub process_res { 752 sub process_res {
548 while (my $job = $c_res->get) {
549 my ($dir, $file, $type) = @$job; 753 my ($dir, $file, $type) = @_;
550 754
551 my $data;
552 aio_load "$dir/$file", $data; 755 0 <= aio_load "$dir/$file", my $data
756 or die "$dir/$file: $!";
553 757
554 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) };
555 759
556 utf8::decode $dir; 760 utf8::decode $dir;
557 utf8::decode $file; 761 utf8::decode $file;
558 762
559 # a meta file for resources is now mandatory 763 # a meta file for resources is now mandatory
560 unless (exists $meta->{$file}) { 764 unless (exists $meta->{$file}) {
561 warn "skipping $dir/$file\n" if $VERBOSE >= 3; 765 warn "skipping $dir/$file\n" if $VERBOSE >= 3;
562 next; 766 return;
563 } 767 }
564 768
565 $meta = { 769 $meta = {
566 %{ $meta->{"" } || {} }, 770 %{ $meta->{"" } || {} },
567 %{ $meta->{$file} || {} }, 771 %{ $meta->{$file} || {} },
568 }; 772 };
569 773
570 if ($meta->{license} =~ s/^#//) { 774 if (exists $meta->{license} && $meta->{license} =~ s/^#//) { # exists == avoid autovivification
571 $meta->{license} = ({ 775 $meta->{license} = ({
572 "pd" => "Public Domain", 776 "pd" => "Public Domain",
573 "gpl" => "GNU General Public License, version 3.0 or any later", 777 "gpl" => "GNU General Public License, version 3.0 or any later",
574 "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/",
575 "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/",
576 "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/",
577 })->{$meta->{license}} 782 })->{$meta->{license}}
578 || warn "$dir/$file: license tag '$meta->{license}' not found."; 783 || warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
579 } 784 }
580 785
786 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
787 ($meta->{author} = $1) =~ s/_/ /g;
788 }
789
581 $file =~ s/\.res$//; 790 $file =~ s/\.res$//;
582 $file =~ s/\.(ogg|wav|jpg|png)$//; 791 $file =~ s/\.(ogg|wav|jpg|png)$//;
583 792
584 substr $dir, 0, 1 + length $PATH, ""; 793 if ($file =~ s/\.plt$//) {
585 794 $data = process_plt "$dir/$file", $data;
586 if (my $filter = $meta->{cfutil_filter}) { 795 } elsif (my $filter = delete $meta->{cfutil_filter}) {
587 if ($filter eq "yaml2json") { 796 if ($filter eq "yaml2json") {
588 $data = JSON::XS::encode_json YAML::XS::Load $data; 797 $data = JSON::XS::encode_json YAML::XS::Load $data;
589 } elsif ($filter eq "json2json") { 798 } elsif ($filter eq "json2json") {
590 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); 799 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
591 } elsif ($filter eq "perl2json") { 800 } elsif ($filter eq "perl2json") {
592 $data = eval $data; die if $@; 801 $data = eval $data; die if $@;
593 $data = JSON::XS::encode_json $data; 802 $data = JSON::XS::encode_json $data;
594 } else { 803 } else {
595 warn "$dir/$file: unknown filter $filter, skipping\n"; 804 warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
596 } 805 }
597 } 806 }
598 807
599 $RESOURCE{"$dir/$file"} = { 808 substr $dir, 0, 1 + length $PATH, "";
809
810 my %info = (
600 type => (exists $meta->{type} ? delete $meta->{type} : $type), 811 type => (exists $meta->{type} ? delete $meta->{type} : $type),
601 data => $data, 812 data => $data,
602 %$meta ? (meta => $meta) : (), 813 %$meta ? (meta => $meta) : (),
603 }; 814 );
815
816 $RESOURCE{"$dir/$file"} = \%info;
817 }
818
819 sub process_any {
820 while (my ($func, @args) = @{ $c_any->get }) {
821 $func->(@args);
604 } 822 }
605 } 823 }
606 824
607 sub find_files; 825 sub find_files;
608 sub find_files { 826 sub find_files {
609 my ($path) = @_; 827 my ($path) = @_;
610 828
829 my $grp = IO::AIO::aio_group;
830
831 my $scandir; $scandir = sub {
832 my ($path) = @_;
833
611 IO::AIO::aioreq_pri 4; 834 IO::AIO::aioreq_pri 4;
612 IO::AIO::aio_scandir $path, 4, sub { 835 add $grp IO::AIO::aio_scandir $path, 4, sub {
613 my ($dirs, $nondirs) = @_; 836 my ($dirs, $nondirs) = @_;
614 837
615 find_files "$path/$_" 838 $scandir->("$path/$_")
616 for grep $_ !~ /^(?:CVS|dev|\..*)$/, @$dirs; 839 for grep $_ !~ /^(?:CVS|dev|\..*)$/, @$dirs;
617 840
618 my $dir = $path; 841 my $dir = $path;
619 substr $dir, 0, 1 + length $PATH, ""; 842 substr $dir, 0, 1 + length $PATH, "";
620 843
621 for my $file (@$nondirs) { 844 for my $file (@$nondirs) {
622 if ($dir =~ /^music(?:\/|$)/) { 845 if ($dir =~ /^music(?:\/|$)/) {
623 $c_res->put ([$path, $file, 3]) # FT_MUSIC 846 $c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
624 if $file =~ /\.(ogg)$/; 847 if $file =~ /\.(ogg)$/;
625 848
626 } elsif ($dir =~ /^sound(?:\/|$)/) { 849 } elsif ($dir =~ /^sound(?:\/|$)/) {
627 $c_res->put ([$path, $file, 5]) # FT_SOUND 850 $c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
628 if $file =~ /\.(wav|ogg)$/; 851 if $file =~ /\.(wav|ogg)$/;
629 852
630 } elsif ($dir =~ /^res(?:\/|$)/) { 853 } elsif ($dir =~ /^res(?:\/|$)/) {
631 if ($file =~ /\.(jpg|png)$/) { 854 if ($file =~ /\.(jpg|png)$/) {
632 $c_res->put ([$path, $file, 0]) # FT_FACE 855 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
633 } elsif ($file =~ /\.(res)$/) { 856 } elsif ($file =~ /\.(res)$/) {
857 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
858 } else {
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
860 }
861
862 } elsif ($file =~ /\.png$/) {
863 $PNG{$file} = $path;
864
865 } elsif ($file =~ /\.faceinfo$/) {
866 $c_any->put ([\&process_faceinfo, $path, $file]);
867
868 } elsif ($file =~ /\.trs$/) {
869 $c_any->put ([\&process_trs, $path, $file]);
870
871 } elsif ($file =~ /\.arc$/) {
634 $c_res->put ([$path, $file, 6]) # FT_RSRC 872 $c_arc->put ([$path, $file]);
873
635 } else { 874 } else {
636 $c_res->put ([$path, $file, undef]); 875 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
637 } 876 }
638
639 } elsif ($file =~ /\.png$/) {
640 push @c_png, ["$path/$file", 0];
641
642 } elsif ($file =~ /\.trs$/) {
643 $c_trs->put ([$path, $file]);
644
645 } elsif ($file =~ /\.arc$/) {
646 $c_arc->put ([$path, $file]);
647
648 } else { 877 }
649 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
650 }
651 } 878 };
652 }; 879 };
880
881 $scandir->($path);
882 aio_wait $grp;
653 } 883 }
654 884
655 sub generate_plurals { 885 sub generate_plurals {
656# use Lingua::EN::Inflect (); 886# use Lingua::EN::Inflect ();
657# Lingua::EN::Inflect::classical; 887# Lingua::EN::Inflect::classical;
… …
691 "Unless you run verbosely, all following warning\n", 921 "Unless you run verbosely, all following warning\n",
692 "or error messages indicate serious problems.\n", 922 "or error messages indicate serious problems.\n",
693 "\n"; 923 "\n";
694 924
695 if (!-d "$path/treasures") { 925 if (!-d "$path/treasures") {
696 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";
697 exit 1 unless $FORCE; 927 exit 1 unless $FORCE;
698 } 928 }
699 929
700 print "scanning files...\n" if $VERBOSE; 930 print "starting file scan, arc, any processing...\n" if $VERBOSE;
931
932 my @a_arc = map +(async \&process_arc), 1..2;
933 my @a_any = map +(async \&process_any), 1..4;
701 934
702 find_files $path; 935 find_files $path;
703 936
704 my @a_arc = map +(async \&process_arc), 1..2;
705 my @a_res = map +(async \&process_res), 1..2;
706 my @a_trs = map +(async \&process_trs), 1..2;
707
708 IO::AIO::flush;
709
710 $c_res->shutdown;
711 $c_arc->shutdown; 937 $c_arc->shutdown;
712 $c_trs->shutdown; 938 $c_any->shutdown;
713
714 print "start file scan, arc, res processing...\n" if $VERBOSE;
715 939
716 $_->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;
717 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
718 print "end arc, start png processing...\n" if $VERBOSE; 966 print "starting png processing...\n" if $VERBOSE;
719 967
720 # eight png crunchers work fine for my 4x smp machine 968 # eight png crunchers work fine for my 4x smp machine
721 my @a_png = map +(async \&process_png), 1..8; 969 my @a_png = map +(async \&process_png), 1..8;
722 970
723 $_->join for (@a_trs, @a_res, @a_png); 971 $_->join for @a_any;
972 print "finished any processing...\n" if $VERBOSE;
973
974 $_->join for @a_png;
975 print "finished png processing...\n" if $VERBOSE;
724 976
725 print "scanning done, processing results...\n" if $VERBOSE; 977 print "scanning done, processing results...\n" if $VERBOSE;
726 { 978 {
727 # remove path prefix from editor_folder 979 # remove path prefix from editor_folder
728 $_->{editor_folder} =~ /^\x00/ 980 $_->{editor_folder} =~ /^\x00/
… …
746 delete @s{qw(_name more name name_pl)}; 998 delete @s{qw(_name more name name_pl)};
747 %$o = ( %s, %$o ); 999 %$o = ( %s, %$o );
748 ++$progress; 1000 ++$progress;
749 } 1001 }
750 } else { 1002 } else {
751 warn "'$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";
752 delete $ARC{$o->{_name}}; 1004 delete $ARC{$o->{_name}};
753 } 1005 }
754 } 1006 }
755 } 1007 }
756 1008
… …
763 } 1015 }
764 1016
765 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit 1017 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
766 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC; 1018 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC;
767 1019
1020 # fix up archetypes without names, where the archanme doesn't work at all
1021 for (@ARC) {
1022 if (!exists $_->{name} and $_->{_name} =~ /_/) {
1023 for ($_->{name} = $_->{_name}) {
1024 s/(?:_\d+)+$//;
1025 s/_[nesw]+$//;
1026 y/_/ /;
1027 }
1028 }
1029 }
1030
768 print "generating plurals...\n" if $VERBOSE; 1031 #print "generating plurals...\n" if $VERBOSE;
769 generate_plurals; 1032 #generate_plurals;
770 1033
771 printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE; 1034 printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
772 open my $fh, ">:utf8", "$DATADIR/archetypes~" 1035 open my $fh, ">:utf8", "$DATADIR/archetypes~"
773 or die "$DATADIR/archetypes~: $!"; 1036 or die "$DATADIR/archetypes~: $!";
774 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];
… …
781 print $fh $TRS; 1044 print $fh $TRS;
782 } 1045 }
783 1046
784 { 1047 {
785 print "processing facedata...\n" if $VERBOSE; 1048 print "processing facedata...\n" if $VERBOSE;
786 while (my ($k, $v) = each %FACEINFO) { 1049
1050 for my $k (sort keys %FACEINFO) {
1051 my $v = $FACEINFO{$k};
1052
787 length $v->{data32} or warn "$k: face 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";
788 length $v->{data64} or warn "$k: face 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";
789 1055
790 make_hash $k, $v->{data32}, $v->{hash32}; 1056 make_hash $k, $v->{data32}, $v->{hash32};
791 make_hash $k, $v->{data64}, $v->{hash64}; 1057 make_hash $k, $v->{data64}, $v->{hash64};
792 1058
793 #length $v->{data32} <= 10000 or warn "$k: 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";
794 #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n"; 1060 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
795 1061
796 if (my $magicmap = $v->{magicmap}) { 1062 $v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
797 $magicmap =~ y/A-Z_\-/a-z/d; 1063 $v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
798 $v->{magicmap} = $COLOR{$magicmap}; 1064 $v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
799 }
800 1065
801 delete $v->{arc}; 1066 if (0 && $v->{w} == 1 && $v->{h} == 1) { # texture catalogs
1067 my $id = @TC;
1068 my $n = @{ $TC[-1] };
1069 my $x = $n % TC_W;
1070 my $y = int $n / TC_W;
1071
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
802 } 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}
803 1108
804 print "processing resources...\n" if $VERBOSE; 1109 print "processing resources...\n" if $VERBOSE;
805 my $enc = JSON::XS->new->utf8->canonical->relaxed; 1110 my $enc = JSON::XS->new->utf8->canonical->relaxed;
806 while (my ($k, $v) = each %RESOURCE) { 1111 for my $k (sort keys %RESOURCE) {
1112 my $v = $RESOURCE{$k};
807 1113
808 if ($v->{meta} && $v->{meta}{datadir}) { 1114 if ($v->{meta} && $v->{meta}{datadir}) {
809 delete $RESOURCE{$k}; 1115 delete $RESOURCE{$k};
810 1116
811 $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/";
… …
830 1136
831 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
832 } 1138 }
833 } 1139 }
834 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
835 printf "writing facedata (%d faces, %d anims, %d resources)...\n", 1172 printf "writing faceinfo (%d faces, %d anims, %d resources)...\n",
836 scalar keys %FACEINFO, 1173 scalar keys %FACEINFO,
837 scalar keys %ANIMINFO, 1174 scalar keys %ANIMINFO,
838 scalar keys %RESOURCE 1175 scalar keys %RESOURCE
839 if $VERBOSE; 1176 if $VERBOSE;
840 1177
841 open my $fh, ">:perlio", "$DATADIR/facedata~" 1178 open my $fh, ">:perlio", "$DATADIR/faceinfo~"
842 or die "$DATADIR/facedata~: $!"; 1179 or die "$DATADIR/faceinfo~: $!";
843 1180
844 print $fh nfreeze { 1181 print $fh nfreeze {
845 version => 2, 1182 version => 2,
846 faceinfo => \%FACEINFO, 1183 faceinfo => \%FACEINFO,
847 animinfo => \%ANIMINFO, 1184 animinfo => \%ANIMINFO,
848 resource => \%RESOURCE, 1185 resource => \%RESOURCE,
849 }; 1186 };
850
851 } 1187 }
852 1188
853 print "committing files...\n" if $VERBOSE; 1189 print "committing files...\n" if $VERBOSE;
854 1190
855 for (qw(archetypes facedata treasures), @COMMIT) { 1191 for (qw(archetypes faceinfo facedata treasures), @COMMIT) {
856 chmod 0644, "$DATADIR/$_~"; 1192 chmod 0644, "$DATADIR/$_~";
857 rename "$DATADIR/$_~", "$DATADIR/$_" 1193 rename "$DATADIR/$_~", "$DATADIR/$_"
858 or die "$DATADIR/$_: $!"; 1194 or die "$DATADIR/$_: $!";
859 } 1195 }
860 1196

Diff Legend

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