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.58 by root, Tue Aug 21 19:44:57 2007 UTC vs.
Revision 1.122 by root, Sun Nov 11 02:24:51 2012 UTC

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

Diff Legend

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