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.61 by root, Thu Aug 30 07:13:17 2007 UTC vs.
Revision 1.121 by root, Mon Oct 29 22:50:10 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
… …
184 unless ($path =~ /~$/) { 294 unless ($path =~ /~$/) {
185 # possibly enlarge 295 # possibly enlarge
186 if (0 > aio_stat "$stem.64x64.png") { 296 if (0 > aio_stat "$stem.64x64.png") {
187 my $other = "$stem.64x64.png~"; 297 my $other = "$stem.64x64.png~";
188 298
189 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 299 make_file $path, $other, sub {
190 fork_sub { 300 fork_exec {
191 my $CROP; 301 my $CROP;
192 my $SRC = "png:\Q$path\E"; 302 my $SRC = "png:\Q$path\E";
193 303
194 my $is_floor = $arc->{is_floor}; 304 my $is_floor = $arc->{is_floor};
195 my $is_wall = 0; 305 my $is_wall = 0;
… …
245 $x * ($w - 8) + 4, 355 $x * ($w - 8) + 4,
246 $y * ($h - 8) + 4; 356 $y * ($h - 8) + 4;
247 } 357 }
248 } 358 }
249 359
250 system "convert -depth 8 $SRC rgba:-" 360 system "$CONVERT -depth 8 $SRC rgba:-"
251 . "| $exec_prefix/bin/cfhq2xa $w $h 0" 361 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
252 . "| 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~"
253 and die "convert/cfhq2xa pipeline error: status $? ($!)"; 363 and die "convert/cfhq2xa pipeline error: status $? ($!)";
254 system $OPTIPNG, "-i0", "-q", "$other~"; 364 optipng "$other~";
255 die "$other~ has zero size, aborting." unless -s "$other~";
256 rename "$other~", $other; 365 rename "$other~", $other;
257 }; 366 };
258 } 367 };
259 368
260 push @c_png, [$other, !$CACHE]; 369 push @c_png, [$other, !$CACHE];
261 } 370 }
262 371
263 # possibly scale down 372 # possibly scale down
264 if (0 > aio_stat "$stem.32x32.png") { 373 if (0 > aio_stat "$stem.32x32.png") {
265 my $other = "$stem.32x32.png~"; 374 my $other = "$stem.32x32.png~";
266 375
267 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 376 make_file $path, $other, sub {
268 fork_sub { 377 fork_exec {
269 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~";
270 system $OPTIPNG, "-i0", "-q", "$other~"; 379 optipng "$other~";
271 380
272 # reduce smoothfaces >10000 bytes 381 # reduce smoothfaces >10000 bytes
382 # obsolete, no longer required
273 if ($stem =~ /_S\./ && (-s "$other~") > 10000) { 383 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
274 my $ncolor = 256; 384 my $ncolor = 256;
275 while () { 385 while () {
276 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E"; 386 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
277 system $OPTIPNG, "-i0", "-q", "$other~~"; 387 optipng "$other~~";
278 last if 10000 > -s "$other~~"; 388 last if 10000 > -s "$other~~";
279 $ncolor = int $ncolor * 0.9; 389 $ncolor = int $ncolor * 0.9;
280 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes"; 390 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
281 } 391 }
282 392
… …
287 } 397 }
288 398
289 die "$other~ has zero size, aborting." unless -s "$other~"; 399 die "$other~ has zero size, aborting." unless -s "$other~";
290 rename "$other~", $other; 400 rename "$other~", $other;
291 }; 401 };
292 } 402 };
293 403
294 #warn "scaled down $path to $other\n";#d# 404 #warn "scaled down $path to $other\n";#d#
295 push @c_png, [$other, !$CACHE]; 405 push @c_png, [$other, !$CACHE];
296 } 406 }
297 } 407 }
298 408
299 (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 }
300 460
301 # split all bigfaces, but avoid smoothfaces (*_S) 461 # split all bigfaces, but avoid smoothfaces (*_S)
302 if (($w > $T || $h > $T) && $face !~ /_S\./) { 462 if (($w > $T || $h > $T) && $face !~ /_S\./) {
303 # split 463 # split
304 my @tile; 464 my @tile;
… …
309 push @tile, [$x, $y, $file, (stat _)[9]]; 469 push @tile, [$x, $y, $file, (stat _)[9]];
310 } 470 }
311 } 471 }
312 472
313 my $mtime = (lstat $path)[9]; 473 my $mtime = (lstat $path)[9];
314 my @todo = grep { $_->[3] <= $mtime } @tile; 474 my @todo = grep { $_->[3] < $mtime } @tile;
315 if (@todo) { 475 if (@todo) {
316 fork_sub { 476 fork_exec {
317 open my $convert, "|-", $CONVERT, 477 open my $convert, "|-", $CONVERT,
318 "png:-", 478 "png:-",
319 (map { 479 (map {
320 ( 480 (
321 "(", 481 "(",
… …
334 print $convert $png; 494 print $convert $png;
335 close $convert; 495 close $convert;
336 496
337 # pass 2, optimise, and rename 497 # pass 2, optimise, and rename
338 for (@todo) { 498 for (@todo) {
339 system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~"; 499 optipng "$_->[2]~";
340 die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
341 rename "$_->[2]~", $_->[2]; 500 rename "$_->[2]~", $_->[2];
342 } 501 }
343 }; 502 };
344 } 503 }
345 504
… …
349 508
350 if (0 > aio_load $file, $tile) { 509 if (0 > aio_load $file, $tile) {
351 die "$path: unable to read tile +$x+$y, aborting.\n"; 510 die "$path: unable to read tile +$x+$y, aborting.\n";
352 } 511 }
353 IO::AIO::aio_unlink $file unless $CACHE; 512 IO::AIO::aio_unlink $file unless $CACHE;
354 commit_png $x|$y ? "$face+$x+$y" : $face, $tile, $T; 513 commit_png $stem, $x|$y ? "$face+$x+$y" : $face, $tile, $T, 1, 1;
355 } 514 }
356 } else { 515 } else {
357 # use as-is (either small, use smooth) 516 # use as-is (either small, use smooth)
358 commit_png $face, $png, $T; 517 commit_png $stem, $face, $png, $T, $w / $T, $h / $T;
359 } 518 }
360 519
361 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 }
362 } 562 }
363 } 563 }
364 564
365 sub process_arc { 565 sub process_arc {
366 while (my $job = $c_arc->get) { 566 while (my ($dir, $file) = @{ $c_arc->get }) {
367 my ($dir, $file) = @$job;
368
369 my $arc; 567 my $arc;
370 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 :/
371 569
372 my $arc = read_arch "$dir/$file"; 570 my $arc = read_arch "$dir/$file";
373 for my $o (values %$arc) { 571 for my $o (values %$arc) {
374 push @ARC, $o; 572 push @ARC, $o;
375 for (my $m = $o; $m; $m = $m->{more}) { 573 for (my $m = $o; $m; $m = $m->{more}) {
376 $ARC{$m->{_name}} = $m; 574 $ARC{$m->{_name}} = $m;
377 } 575 }
378 576
379 $o->{editor_folder} = $dir; 577 $o->{editor_folder} ||= "\x00$dir"; # horrible kludge
380
381 my $visibility = delete $o->{visibility};
382 my $magicmap = delete $o->{magicmap};
383 578
384 # find upper left corner :/ 579 # find upper left corner :/
385 # omg, this is sooo broken 580 # omg, this is sooo broken
386 my ($dx, $dy); 581 my ($dx, $dy);
387 for (my $o = $o; $o; $o = $o->{more}) { 582 for (my $o = $o; $o; $o = $o->{more}) {
… …
394 my $y = $o->{y} - $dy; 589 my $y = $o->{y} - $dy;
395 590
396 my $ext = $x|$y ? "+$x+$y" : ""; 591 my $ext = $x|$y ? "+$x+$y" : "";
397 592
398 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face}; 593 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face};
399
400 $visibility = delete $o->{visibility} if exists $o->{visibility};
401 $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
402 594
403 my $anim = delete $o->{anim}; 595 my $anim = delete $o->{anim};
404 596
405 if ($anim) { 597 if ($anim) {
406 # possibly add $ext to the animation name to avoid 598 # possibly add $ext to the animation name to avoid
… …
430 next if /^facings\s/; 622 next if /^facings\s/;
431 623
432 my $face = $_; 624 my $face = $_;
433 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates 625 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
434 626
435 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
436 $info->{arc} = $o; 633 $FACEINFO{$face}{arc} = $o;
437 634
438 next if $face =~ /^blank.x11$|^empty.x11$/; 635 next if $face =~ /^blank.x11$|^empty.x11$/;
439
440 $info->{visibility} = $visibility if defined $visibility;
441 $info->{magicmap} = $magicmap if defined $magicmap;
442 } 636 }
443 637
444 if (my $smooth = delete $o->{smoothface}) { 638 if (my $smooth = delete $o->{smoothface}) {
445 my %kv = split /\s+/, $smooth; 639 my %kv = split /\s+/, $smooth;
446 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 640 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
… …
455 } 649 }
456 } 650 }
457 } 651 }
458 652
459 sub process_trs { 653 sub process_trs {
460 while (my $job = $c_trs->get) {
461 my ($dir, $file) = @$job; 654 my ($dir, $file) = @_;
462 my $path = "$dir/$file"; 655 my $path = "$dir/$file";
463 656
464 my $trs; 657 my $trs;
465 if (0 > aio_load $path, $trs) { 658 if (0 > aio_load $path, $trs) {
466 warn "$path: $!, skipping.\n"; 659 warn "ERROR: $path: $!, skipping.\n";
467 next; 660 return;
468 } 661 }
469 662
470 $TRS .= $trs; 663 $TRS .= $trs;
471 }
472 } 664 }
473 665
474 my %FILECACHE; 666 my %FILECACHE;
475 667
476 sub load_cached($;$) { 668 sub load_cached($;$) {
477 unless (exists $FILECACHE{$_[0]}) { 669 unless (exists $FILECACHE{$_[0]}) {
478 my $data; 670 my $data;
479 if (0 < aio_load $_[0], $data) { 671 if (0 < aio_load $_[0], $data) {
480 if ($_[1]) { 672 if ($_[1]) {
481 $data = eval { $_[1]->($data) }; 673 $data = eval { $_[1]->($data) };
482 warn "$_[0]: $@" if $@; 674 warn "ERROR: $_[0]: $@" if $@;
483 } 675 }
484 } 676 }
485 677
486 $FILECACHE{$_[0]} = $data; 678 $FILECACHE{$_[0]} = $data;
487 } 679 }
488 680
489 $FILECACHE{$_[0]} 681 $FILECACHE{$_[0]}
490 } 682 }
491 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
492 sub process_res { 752 sub process_res {
493 while (my $job = $c_res->get) {
494 my ($dir, $file, $type) = @$job; 753 my ($dir, $file, $type) = @_;
495 754
496 my $data;
497 aio_load "$dir/$file", $data; 755 0 <= aio_load "$dir/$file", my $data
756 or die "$dir/$file: $!";
498 757
499
500 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) };
501 759
502 utf8::decode $dir; 760 utf8::decode $dir;
503 utf8::decode $file; 761 utf8::decode $file;
504 762
505 # a meta file for resources is now mandatory 763 # a meta file for resources is now mandatory
506 unless (exists $meta->{$file}) { 764 unless (exists $meta->{$file}) {
507 warn "skipping $dir/$file\n" if $VERBOSE >= 3; 765 warn "skipping $dir/$file\n" if $VERBOSE >= 3;
508 next; 766 return;
509 } 767 }
510 768
511 $meta = { 769 $meta = {
512 %{ $meta->{"" } || {} }, 770 %{ $meta->{"" } || {} },
513 %{ $meta->{$file} || {} }, 771 %{ $meta->{$file} || {} },
514 }; 772 };
515 773
516 if ($meta->{license} =~ s/^#//) { 774 if (exists $meta->{license} && $meta->{license} =~ s/^#//) { # exists == avoid autovivification
517 $meta->{license} = ({ 775 $meta->{license} = ({
518 "pd" => "Public Domain", 776 "pd" => "Public Domain",
519 "gpl" => "GNU General Public License, version 3.0 or any later", 777 "gpl" => "GNU General Public License, version 3.0 or any later",
520 "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/",
521 "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/",
522 "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/",
523 })->{$meta->{license}} 782 })->{$meta->{license}}
524 || warn "$dir/$file: license tag '$meta->{license}' not found."; 783 || warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
525 } 784 }
526 785
786 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
787 ($meta->{author} = $1) =~ s/_/ /g;
788 }
789
527 $file =~ s/\.res$//; 790 $file =~ s/\.res$//;
528 $file =~ s/\.(ogg|wav|jpg|png)$//; 791 $file =~ s/\.(ogg|wav|jpg|png)$//;
529 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
530 substr $dir, 0, 1 + length $PATH, ""; 808 substr $dir, 0, 1 + length $PATH, "";
531 809
532 $RESOURCE{"$dir/$file"} = { 810 $RESOURCE{"$dir/$file"} = {
533 type => (delete $meta->{type}) || $type, 811 type => (exists $meta->{type} ? delete $meta->{type} : $type),
534 data => $data, 812 data => $data,
535 %$meta ? (meta => $meta) : (), 813 %$meta ? (meta => $meta) : (),
536 }; 814 };
815 }
816
817 sub process_any {
818 while (my ($func, @args) = @{ $c_any->get }) {
819 $func->(@args);
537 } 820 }
538 } 821 }
539 822
540 sub find_files; 823 sub find_files;
541 sub find_files { 824 sub find_files {
542 my ($path) = @_; 825 my ($path) = @_;
543 826
827 my $grp = IO::AIO::aio_group;
828
829 my $scandir; $scandir = sub {
830 my ($path) = @_;
831
544 IO::AIO::aioreq_pri 4; 832 IO::AIO::aioreq_pri 4;
545 IO::AIO::aio_scandir $path, 4, sub { 833 add $grp IO::AIO::aio_scandir $path, 4, sub {
546 my ($dirs, $nondirs) = @_; 834 my ($dirs, $nondirs) = @_;
547 835
548 find_files "$path/$_" 836 $scandir->("$path/$_")
549 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs; 837 for grep $_ !~ /^(?:CVS|dev|\..*)$/, @$dirs;
550 838
551 my $dir = $path; 839 my $dir = $path;
552 substr $dir, 0, 1 + length $PATH, ""; 840 substr $dir, 0, 1 + length $PATH, "";
553 841
554 for my $file (@$nondirs) { 842 for my $file (@$nondirs) {
555 if ($dir =~ /^music(?:\/|$)/) { 843 if ($dir =~ /^music(?:\/|$)/) {
556 $c_res->put ([$path, $file, 3]) # FT_MUSIC 844 $c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
557 if $file =~ /\.(ogg)$/; 845 if $file =~ /\.(ogg)$/;
558 846
559 } elsif ($dir =~ /^sound(?:\/|$)/) { 847 } elsif ($dir =~ /^sound(?:\/|$)/) {
560 $c_res->put ([$path, $file, 5]) # FT_SOUND 848 $c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
561 if $file =~ /\.(wav|ogg)$/; 849 if $file =~ /\.(wav|ogg)$/;
562 850
563 } elsif ($dir =~ /^res(?:\/|$)/) { 851 } elsif ($dir =~ /^res(?:\/|$)/) {
564 $c_res->put ([$path, $file, 0]) # FT_FACE
565 if $file =~ /\.(jpg|png)$/; 852 if ($file =~ /\.(jpg|png)$/) {
566 $c_res->put ([$path, $file, 7]) # FT_RSRC 853 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
567 if $file =~ /\.(res)$/; 854 } elsif ($file =~ /\.(res)$/) {
855 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
856 } else {
857 $c_any->put ([\&process_res, $path, $file, 6]); # was type undef, but now meta files are mandatory, so any mentioned file surely has a purpose
858 }
568 859
569 } elsif ($file =~ /\.png$/) { 860 } elsif ($file =~ /\.png$/) {
570 push @c_png, ["$path/$file", 0]; 861 $PNG{$file} = $path;
571 862
863 } elsif ($file =~ /\.faceinfo$/) {
864 $c_any->put ([\&process_faceinfo, $path, $file]);
865
572 } elsif ($file =~ /\.trs$/) { 866 } elsif ($file =~ /\.trs$/) {
573 $c_trs->put ([$path, $file]); 867 $c_any->put ([\&process_trs, $path, $file]);
574 868
575 } elsif ($file =~ /\.arc$/) { 869 } elsif ($file =~ /\.arc$/) {
576 $c_arc->put ([$path, $file]); 870 $c_arc->put ([$path, $file]);
577 871
578 } else { 872 } else {
579 warn "ignoring $path/$file\n" if $VERBOSE >= 3; 873 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
580 } 874 }
875 }
581 } 876 };
582 }; 877 };
878
879 $scandir->($path);
880 aio_wait $grp;
881 }
882
883 sub generate_plurals {
884# use Lingua::EN::Inflect ();
885# Lingua::EN::Inflect::classical;
886# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
887# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
888#
889# for my $a (@ARC) {
890# my $name = $a->{name} || $a->{_name};
891#
892# next unless $a->{name_pl};
893# next if $a->{invisible};
894# next if $a->{is_floor};
895# next if $a->{no_pick};
896#
897# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
898# my $pl = $test =~ /^(?:eq|p:.)$/
899# ? $name
900# : Lingua::EN::Inflect::PL $name;
901#
902# if ($pl ne $a->{name_pl}) {
903# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
904# }
905# }
583 } 906 }
584 907
585 sub inst_arch($) { 908 sub inst_arch($) {
586 my (undef, $path) = @_; 909 my (undef, $path) = @_;
587 910
… …
596 "Unless you run verbosely, all following warning\n", 919 "Unless you run verbosely, all following warning\n",
597 "or error messages indicate serious problems.\n", 920 "or error messages indicate serious problems.\n",
598 "\n"; 921 "\n";
599 922
600 if (!-d "$path/treasures") { 923 if (!-d "$path/treasures") {
601 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 924 warn "FATAL: '$path' does not look like an arch directory ('treasures' directory is missing).\n";
602 exit 1 unless $FORCE; 925 exit 1 unless $FORCE;
603 } 926 }
604 927
605 print "scanning files...\n" if $VERBOSE; 928 print "starting file scan, arc, any processing...\n" if $VERBOSE;
929
930 my @a_arc = map +(async \&process_arc), 1..2;
931 my @a_any = map +(async \&process_any), 1..4;
606 932
607 find_files $path; 933 find_files $path;
608 934
609 my @a_arc = map +(async \&process_arc), 1..2; 935 $c_arc->shutdown;
610 my @a_res = map +(async \&process_res), 1..2; 936 $c_any->shutdown;
611 my @a_trs = map +(async \&process_trs), 1..2;
612
613 IO::AIO::flush;
614
615 $c_res->put (undef) for @a_res;
616 $c_arc->put (undef) for @a_arc;
617 $c_trs->put (undef) for @a_trs;
618
619 print "start file scan, arc, res processing...\n" if $VERBOSE;
620 937
621 $_->join for @a_arc; # need to parse all archetypes before png processing 938 $_->join for @a_arc; # need to parse all archetypes before png processing
939 print "finished arc processing...\n" if $VERBOSE;
622 940
941 # fill png queue
942 for (keys %FACEINFO) {
943 # we only expect source pngs to exist for non-derived
944 # faces, i.e. no split tiles (+x+x) and no face derivates
945 # (xxx:)
946 /^[^:]+\....$/
947 or next;
948
949 my $seen;
950
951 if (exists $PNG{"$_.32x32.png"}) {
952 push @c_png, ["$PNG{\"$_.32x32.png\"}/$_.32x32.png"];
953 $seen = 1;
954 }
955 if (exists $PNG{"$_.64x64.png"}) {
956 push @c_png, ["$PNG{\"$_.64x64.png\"}/$_.64x64.png"];
957 $seen = 1;
958 }
959
960 warn "ERROR: $_: face not found, expect problems.\n"
961 unless $seen;
962 }
963
623 print "end arc, start png processing...\n" if $VERBOSE; 964 print "starting png processing...\n" if $VERBOSE;
624 965
625 # four png crunchers work fine for my 2x smp machine 966 # eight png crunchers work fine for my 4x smp machine
626 my @a_png = map +(async \&process_png), 1..4; 967 my @a_png = map +(async \&process_png), 1..8;
627 968
628 $_->join for (@a_trs, @a_res, @a_png); 969 $_->join for @a_any;
970 print "finished any processing...\n" if $VERBOSE;
971
972 $_->join for @a_png;
973 print "finished png processing...\n" if $VERBOSE;
629 974
630 print "scanning done, processing results...\n" if $VERBOSE; 975 print "scanning done, processing results...\n" if $VERBOSE;
631 { 976 {
632 # remove path prefix from editor_folder 977 # remove path prefix from editor_folder
978 $_->{editor_folder} =~ /^\x00/
633 substr $_->{editor_folder}, 0, 1 + length $path, "" 979 and substr $_->{editor_folder}, 0, 2 + length $path, ""
634 for values %ARC; 980 for values %ARC;
635 981
636 print "resolving inheritance tree...\n" if $VERBOSE; 982 print "resolving inheritance tree...\n" if $VERBOSE;
637 # resolve inherit 983 # resolve inherit
638 while () { 984 while () {
639 my $progress; 985 my $progress;
640 my $loop; 986 my $loop;
641 987
642 for my $o (values %ARC) { 988 for my $o (values %ARC) {
643 if (my $other = $o->{inherit}) { 989 for my $other (split /,/, $o->{inherit}) {
644 if (my $s = $ARC{$other}) { 990 if (my $s = $ARC{$other}) {
645 if ($s->{inherit}) { 991 if ($s->{inherit}) {
646 $loop = $s; 992 $loop = $s;
647 } else { 993 } else {
648 delete $o->{inherit}; 994 delete $o->{inherit};
… …
650 delete @s{qw(_name more name name_pl)}; 996 delete @s{qw(_name more name name_pl)};
651 %$o = ( %s, %$o ); 997 %$o = ( %s, %$o );
652 ++$progress; 998 ++$progress;
653 } 999 }
654 } else { 1000 } else {
655 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n"; 1001 warn "ERROR: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
656 delete $ARC{$o->{_name}}; 1002 delete $ARC{$o->{_name}};
657 } 1003 }
658 } 1004 }
659 } 1005 }
660 1006
… …
667 } 1013 }
668 1014
669 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit 1015 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
670 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC; 1016 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC;
671 1017
1018 # fix up archetypes without names, where the archanme doesn't work at all
1019 for (@ARC) {
1020 if (!exists $_->{name} and $_->{_name} =~ /_/) {
1021 for ($_->{name} = $_->{_name}) {
1022 s/(?:_\d+)+$//;
1023 s/_[nesw]+$//;
1024 y/_/ /;
1025 }
1026 }
1027 }
1028
1029 #print "generating plurals...\n" if $VERBOSE;
1030 #generate_plurals;
1031
672 print "writing archetypes...\n" if $VERBOSE; 1032 printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
673 open my $fh, ">:utf8", "$DATADIR/archetypes~" 1033 open my $fh, ">:utf8", "$DATADIR/archetypes~"
674 or die "$DATADIR/archetypes~: $!"; 1034 or die "$DATADIR/archetypes~: $!";
675 print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC]; 1035 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
676 } 1036 }
677 1037
678 { 1038 {
679 print "writing treasures...\n" if $VERBOSE; 1039 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
680 open my $fh, ">:utf8", "$DATADIR/treasures~" 1040 open my $fh, ">:utf8", "$DATADIR/treasures~"
681 or die "$DATADIR/treasures~: $!"; 1041 or die "$DATADIR/treasures~: $!";
682 print $fh $TRS; 1042 print $fh $TRS;
683 } 1043 }
684 1044
685 { 1045 {
686 print "processing facedata...\n" if $VERBOSE; 1046 print "processing facedata...\n" if $VERBOSE;
687 while (my ($k, $v) = each %FACEINFO) {
688 length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
689 length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
690
691 length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";
692 #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
693
694 if (my $magicmap = $v->{magicmap}) {
695 $magicmap =~ y/A-Z_\-/a-z/d;
696 $v->{magicmap} = $COLOR{$magicmap};
697 }
698
699 delete $v->{arc};
700 } 1047
1048 for my $k (sort keys %FACEINFO) {
1049 my $v = $FACEINFO{$k};
701 1050
1051 length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
1052 length $v->{data64} or warn "ERROR: face '$k' has no png64 - this will not work.\n";
1053
1054 make_hash $k, $v->{data32}, $v->{hash32};
1055 make_hash $k, $v->{data64}, $v->{hash64};
1056
1057 #length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
1058 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
1059
1060 $v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
1061 $v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
1062 $v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
1063
1064 if (0 && $v->{w} == 1 && $v->{h} == 1) { # texture catalogs
1065 my $id = @TC;
1066 my $n = @{ $TC[-1] };
1067 my $x = $n % TC_W;
1068 my $y = int $n / TC_W;
1069
1070 push @{ $TC[-1] }, [$v, $x, $y];
1071
1072 $v->{tc} = [$id, $x, $y];
1073
1074 push @TC, [] if $n == TC_W * TC_H - 1; # start new texture if full
1075 }
1076
1077 delete @$v{qw(w h arc stem derive)}; # not used by the server
1078 }
1079
1080if (0) { #d# texture catalogs
702 print "writing facedata...\n" if $VERBOSE; 1081 print "creating texture catalogs...\n" if $VERBOSE;
1082
1083 for my $id (0 .. $#TC) {
1084 my $tc = $TC[$id];
1085
1086 my $cmd = "$CONVERT -depth 8 -size " . (TC_W * 64) . "x" . (TC_H * 64) . " xc:transparent";
1087 my $idx = "a";
1088
1089 for (@$tc) {
1090 my $path = "$TMPDIR/tc" . $idx++;
1091
1092 open my $fh, ">:perlio", $path
1093 or die "$path: $!";
1094 syswrite $fh, $_->[0]{data64};
1095
1096 my $x = $_->[1] * 64;
1097 my $y = $_->[2] * 64;
1098
1099 $cmd .= " png:\Q$path\E -geometry +$x+$y -composite";
1100 }
1101
1102 system "$cmd png:\Q$TMPDIR/tc$id\E";
1103 optipng "$TMPDIR/tc$id";
1104 }
1105}
1106
1107 print "processing resources...\n" if $VERBOSE;
1108 my $enc = JSON::XS->new->utf8->canonical->relaxed;
1109 while (my ($k, $v) = each %RESOURCE) {
1110
1111 if ($v->{meta} && $v->{meta}{datadir}) {
1112 delete $RESOURCE{$k};
1113
1114 $k =~ s/^res\/// or die "$k: datadir files must be in res/";
1115
1116 printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
1117 open my $fh, ">:raw", "$DATADIR/$k~"
1118 or die "$DATADIR/$k~: $!";
1119 syswrite $fh, $v->{data};
1120 push @COMMIT, $k;
1121
1122 } else {
1123 if ($v->{type} & 1) {
1124 # prepend meta info
1125
1126 my $meta = $enc->encode ({
1127 name => $k,
1128 %{ $v->{meta} || {} },
1129 });
1130
1131 $v->{data} = pack "(w/a*)*", $meta, $v->{data};
1132 }
1133
1134 make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
1135 }
1136 }
1137
1138 printf "writing facedata (%d faces, %d anims, %d resources)...\n",
1139 scalar keys %FACEINFO,
1140 scalar keys %ANIMINFO,
1141 scalar keys %RESOURCE
1142 if $VERBOSE;
1143
703 open my $fh, ">:perlio", "$DATADIR/facedata~" 1144 open my $fh, ">:perlio", "$DATADIR/facedata~"
704 or die "$DATADIR/facedata~: $!"; 1145 or die "$DATADIR/facedata~: $!";
705 1146
706 print $fh freeze { 1147 print $fh nfreeze {
707 version => 2, 1148 version => 2,
708 faceinfo => \%FACEINFO, 1149 faceinfo => \%FACEINFO,
709 animinfo => \%ANIMINFO, 1150 animinfo => \%ANIMINFO,
710 resource => \%RESOURCE, 1151 resource => \%RESOURCE,
711 }; 1152 };
712 } 1153 }
713 1154
714 print "committing files...\n" if $VERBOSE; 1155 print "committing files...\n" if $VERBOSE;
715 1156
716 for (qw(archetypes facedata treasures)) { 1157 for (qw(archetypes facedata treasures), @COMMIT) {
717 chmod 0644, "$DATADIR/$_~"; 1158 chmod 0644, "$DATADIR/$_~";
718 rename "$DATADIR/$_~", "$DATADIR/$_" 1159 rename "$DATADIR/$_~", "$DATADIR/$_"
719 or die "$DATADIR/$_: $!"; 1160 or die "$DATADIR/$_: $!";
720 } 1161 }
721 1162

Diff Legend

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