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

Diff Legend

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