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.106 by root, Wed Oct 20 06:21:48 2010 UTC vs.
Revision 1.119 by root, Wed Jan 4 02:48:57 2012 UTC

1#!@PERL@ 1#!@PERL@
2 2
3# 3#
4# This file is part of Deliantra, the Roguelike Realtime MMORPG. 4# This file is part of Deliantra, the Roguelike Realtime MMORPG.
5# 5#
6# Copyright (©) 2007,2008,2009 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 6# Copyright (©) 2007,2008,2009,2010,2011,2012 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
7# 7#
8# Deliantra is free software: you can redistribute it and/or modify it under 8# Deliantra is free software: you can redistribute it and/or modify it under
9# the terms of the Affero GNU General Public License as published by the 9# the terms of the Affero GNU General Public License as published by the
10# Free Software Foundation, either version 3 of the License, or (at your 10# Free Software Foundation, either version 3 of the License, or (at your
11# option) any later version. 11# option) any later version.
… …
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" };
… …
104 khaki => 12, 107 khaki => 12,
105); 108);
106 109
107END { system "rm", "-rf", $TMPDIR } 110END { system "rm", "-rf", $TMPDIR }
108 111
109my $s_INT = EV::signal INT => sub { exit 1 }; 112my $s_INT = AE::signal INT => sub { exit 1 };
110my $s_TERM = EV::signal TERM => sub { exit 1 }; 113my $s_TERM = AE::signal TERM => sub { exit 1 };
111 114
112our %hash; 115our %hash;
113 116
114# 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
115sub make_hash($\$\$;$) { 118sub make_hash($\$\$;$) {
116 my ($id, $dataref, $hashref, $clen) = @_; 119 my ($id, $dataref, $hashref, $clen) = @_;
117 120
118 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 4; 121 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 5;
119 122
120 if (exists $hash{$hash}) { 123 if (exists $hash{$hash}) {
121 # hash collision, but some files are simply identical 124 # hash collision, but some files are simply identical
122 if (${$hash{$hash}[1]} ne $$dataref) { 125 if (${$hash{$hash}[1]} ne $$dataref) {
123 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";
124 exit 1; 127 exit 1;
125 } else { 128 } else {
126 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;
127 } 130 }
128 } 131 }
129 $hash{$hash} = [$id, $dataref, $hashref]; 132 $hash{$hash} = [$id, $dataref, $hashref];
130 133
131 $$hashref = $hash; 134 $$hashref = $hash;
132} 135}
133 136
137sub optipng($) {
138 system $OPTIPNG, "-o5", "-i0", "-q", $_[0];
139 die "$_[0] has zero size, aborting." unless -s $_[0];
140}
141
134mkdir $TMPDIR, 0700 142mkdir $TMPDIR, 0700
135 or die "$TMPDIR: $!"; 143 or die "$TMPDIR: $!";
136 144
137sub fork_sub(&) { 145sub fork_exec(&) {
138 my ($cb) = @_; 146 my ($cb) = @_;
139 147
140 if (my $pid = fork) { 148 if (my $pid = fork) {
141 my $current = $Coro::current; 149 my $current = $Coro::current;
142 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); 150 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
… …
147 warn $@; 155 warn $@;
148 POSIX::_exit 1; 156 POSIX::_exit 1;
149 } 157 }
150} 158}
151 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
152sub inst_maps($) { 189sub inst_maps($) {
153 my (undef, $path) = @_; 190 my (undef, $path) = @_;
154 191
155 print "\nInstalling '$path' to '$DATADIR/maps'\n\n"; 192 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
156 193
157 if (!-f "$path/regions") { 194 if (!-f "$path/regions") {
158 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";
159 exit 1 unless $FORCE; 196 exit 1 unless $FORCE;
160 } 197 }
161 198
162 system $RSYNC, "-av", "--chmod=u=rwX,go=rX", 199 system $RSYNC, "-av", "--chmod=u=rwX,go=rX",
163 "$path/.", "$DATADIR/maps/.", 200 "$path/.", "$DATADIR/maps/.",
… …
173 our %FACEINFO; 210 our %FACEINFO;
174 our %RESOURCE; 211 our %RESOURCE;
175 our @ARC; 212 our @ARC;
176 our %ARC; 213 our %ARC;
177 our $TRS; 214 our $TRS;
215 our %PNG;
178 our $NFILE; 216 our $NFILE;
179 our $PATH; 217 our $PATH;
180 218
181 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 219 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
182 220
… …
199 my $png; 237 my $png;
200 aio_lstat $path; 238 aio_lstat $path;
201 my ($size, $mtime) = (stat _)[7,9]; 239 my ($size, $mtime) = (stat _)[7,9];
202 240
203 if (0 > aio_load $path, $png) { 241 if (0 > aio_load $path, $png) {
204 warn "$path: $!, skipping.\n"; 242 warn "ERROR: $path: $!, skipping.\n";
205 next; 243 next;
206 } 244 }
207 245
208 my $stem = $path; 246 my $stem = $path;
209 my $T; 247 my $T;
… …
211 if ($stem =~ s/\.32x32\.png~?$//) { 249 if ($stem =~ s/\.32x32\.png~?$//) {
212 $T = 32; 250 $T = 32;
213 } elsif ($stem =~ s/\.64x64\.png~?$//) { 251 } elsif ($stem =~ s/\.64x64\.png~?$//) {
214 $T = 64; 252 $T = 64;
215 } else { 253 } else {
216 warn "$path: weird filename, skipping.\n"; 254 warn "ERROR: $path: weird filename, skipping.\n";
217 next; 255 next;
218 } 256 }
219 257
220 # quickly extract width and height of the (necessarily PNG) image 258 # quickly extract width and height of the (necessarily PNG) image
221 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) { 259 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
222 warn "$path: not a recognized png file, skipping.\n"; 260 warn "ERROR: $path: not a recognized png file, skipping.\n";
223 next; 261 next;
224 } 262 }
225 263
226 my ($w, $h) = unpack "NN", $1; 264 my ($w, $h) = unpack "NN", $1;
227 265
228 if ($w < $T || $h < $T) { 266 if ($w < $T || $h < $T) {
229 warn "$path: too small ($w $h), skipping.\n"; 267 warn "ERROR: $path: too small ($w $h), skipping.\n";
230 next; 268 next;
231 } 269 }
232 270
233 if ($w % $T || $h % $T) { 271 if ($w % $T || $h % $T) {
234 warn "$path: weird png size ($w $h), skipping.\n"; 272 warn "ERROR: $path: weird png size ($w $h), skipping.\n";
235 next; 273 next;
236 } 274 }
237 275
238 (my $base = $stem) =~ s/^.*\///; 276 (my $base = $stem) =~ s/^.*\///;
239 277
… …
248 unless ($path =~ /~$/) { 286 unless ($path =~ /~$/) {
249 # possibly enlarge 287 # possibly enlarge
250 if (0 > aio_stat "$stem.64x64.png") { 288 if (0 > aio_stat "$stem.64x64.png") {
251 my $other = "$stem.64x64.png~"; 289 my $other = "$stem.64x64.png~";
252 290
253 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 291 make_file $path, $other, sub {
254 fork_sub { 292 fork_exec {
255 my $CROP; 293 my $CROP;
256 my $SRC = "png:\Q$path\E"; 294 my $SRC = "png:\Q$path\E";
257 295
258 my $is_floor = $arc->{is_floor}; 296 my $is_floor = $arc->{is_floor};
259 my $is_wall = 0; 297 my $is_wall = 0;
… …
313 351
314 system "convert -depth 8 $SRC rgba:-" 352 system "convert -depth 8 $SRC rgba:-"
315 . "| $exec_prefix/bin/cfhq2xa $w $h 0" 353 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
316 . "| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $CROP $QUANTIZE -quality 00 png32:\Q$other\E~" 354 . "| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $CROP $QUANTIZE -quality 00 png32:\Q$other\E~"
317 and die "convert/cfhq2xa pipeline error: status $? ($!)"; 355 and die "convert/cfhq2xa pipeline error: status $? ($!)";
318 system $OPTIPNG, "-i0", "-q", "$other~"; 356 optipng "$other~";
319 die "$other~ has zero size, aborting." unless -s "$other~";
320 rename "$other~", $other; 357 rename "$other~", $other;
321 }; 358 };
322 } 359 };
323 360
324 push @c_png, [$other, !$CACHE]; 361 push @c_png, [$other, !$CACHE];
325 } 362 }
326 363
327 # possibly scale down 364 # possibly scale down
328 if (0 > aio_stat "$stem.32x32.png") { 365 if (0 > aio_stat "$stem.32x32.png") {
329 my $other = "$stem.32x32.png~"; 366 my $other = "$stem.32x32.png~";
330 367
331 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 368 make_file $path, $other, sub {
332 fork_sub { 369 fork_exec {
333 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~"; 370 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
334 system $OPTIPNG, "-i0", "-q", "$other~"; 371 optipng "$other~";
335 372
336 # reduce smoothfaces >10000 bytes 373 # reduce smoothfaces >10000 bytes
337 # obsolete, no longer required 374 # obsolete, no longer required
338 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) { 375 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
339 my $ncolor = 256; 376 my $ncolor = 256;
340 while () { 377 while () {
341 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E"; 378 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
342 system $OPTIPNG, "-i0", "-q", "$other~~"; 379 optipng "$other~~";
343 last if 10000 > -s "$other~~"; 380 last if 10000 > -s "$other~~";
344 $ncolor = int $ncolor * 0.9; 381 $ncolor = int $ncolor * 0.9;
345 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes"; 382 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
346 } 383 }
347 384
… …
352 } 389 }
353 390
354 die "$other~ has zero size, aborting." unless -s "$other~"; 391 die "$other~ has zero size, aborting." unless -s "$other~";
355 rename "$other~", $other; 392 rename "$other~", $other;
356 }; 393 };
357 } 394 };
358 395
359 #warn "scaled down $path to $other\n";#d# 396 #warn "scaled down $path to $other\n";#d#
360 push @c_png, [$other, !$CACHE]; 397 push @c_png, [$other, !$CACHE];
361 } 398 }
362 } 399 }
363 400
364 (my $face = $stem) =~ s/^.*\///; 401 (my $face = $stem) =~ s/^.*\///;
402
403 for (@{ $fi->{derive} }) {
404 my ($dir, $type) = @$_;
405
406 my $geom = "${T}x${T}";
407 my $dpath = "$dir/$type:$face.$geom.png~";
408
409 if ($type eq "buildmaterial") {
410 my $ov = "$PATH/mapbuilding/buildmaterial.png";
411 make_file [$path, $ov], $dpath, sub {
412 fork_exec {
413 system "$CONVERT -size 64x64 xc:transparent \\( \Q$path\E -geometry 52x52+6+6 \\) -composite \Q$ov\E -composite -geometry $geom png:\Q$dpath\E~";
414 optipng "$dpath~";
415 rename "$dpath~", $dpath;
416 };
417 };
418 } elsif ($type eq "buildmaterial-box") {
419 my $ov = "$PATH/mapbuilding/buildmaterial-box.png";
420 make_file [$path, $ov], $dpath, sub {
421 fork_exec {
422 system "$CONVERT \Q$ov\E "
423 . "\\( \Q$path\E -trim -geometry 34x31\\> "
424 . "-gravity center -background transparent -extent 37x34 +gravity "
425 . "-geometry +22+6 \\) -composite "
426 . "-geometry $geom png:\Q$dpath\E~";
427 optipng "$dpath~";
428 rename "$dpath~", $dpath;
429 };
430 };
431 } elsif ($type eq "buildmaterial-sbox") {
432 my $ov = "$PATH/mapbuilding/buildmaterial-sbox.png";
433 make_file [$path, $ov], $dpath, sub {
434 fork_exec {
435 system "$CONVERT \Q$ov\E "
436 . "\\( \Q$path\E -trim -geometry 16x24\\> "
437 . "-gravity center -background transparent -extent 18x26 +gravity "
438 . "-geometry +26+16 \\) -composite "
439 . "-geometry $geom png:\Q$dpath\E~";
440 optipng "$dpath~";
441 rename "$dpath~", $dpath;
442 };
443 };
444 } else {
445 warn "ERROR: facename $type:$face contains unsupported derivation type.\n";
446 }
447
448 aio_load $dpath, my $png;
449 IO::AIO::aio_unlink $dpath unless $CACHE;
450 commit_png "$dir/$type:$face", "$type:$face", $png, $T;
451 }
365 452
366 # split all bigfaces, but avoid smoothfaces (*_S) 453 # split all bigfaces, but avoid smoothfaces (*_S)
367 if (($w > $T || $h > $T) && $face !~ /_S\./) { 454 if (($w > $T || $h > $T) && $face !~ /_S\./) {
368 # split 455 # split
369 my @tile; 456 my @tile;
… …
374 push @tile, [$x, $y, $file, (stat _)[9]]; 461 push @tile, [$x, $y, $file, (stat _)[9]];
375 } 462 }
376 } 463 }
377 464
378 my $mtime = (lstat $path)[9]; 465 my $mtime = (lstat $path)[9];
379 my @todo = grep { $_->[3] <= $mtime } @tile; 466 my @todo = grep { $_->[3] < $mtime } @tile;
380 if (@todo) { 467 if (@todo) {
381 fork_sub { 468 fork_exec {
382 open my $convert, "|-", $CONVERT, 469 open my $convert, "|-", $CONVERT,
383 "png:-", 470 "png:-",
384 (map { 471 (map {
385 ( 472 (
386 "(", 473 "(",
… …
399 print $convert $png; 486 print $convert $png;
400 close $convert; 487 close $convert;
401 488
402 # pass 2, optimise, and rename 489 # pass 2, optimise, and rename
403 for (@todo) { 490 for (@todo) {
404 system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~"; 491 optipng "$_->[2]~";
405 die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
406 rename "$_->[2]~", $_->[2]; 492 rename "$_->[2]~", $_->[2];
407 } 493 }
408 }; 494 };
409 } 495 }
410 496
… …
421 } else { 507 } else {
422 # use as-is (either small, use smooth) 508 # use as-is (either small, use smooth)
423 commit_png $stem, $face, $png, $T; 509 commit_png $stem, $face, $png, $T;
424 } 510 }
425 511
426 aio_unlink $path if $delete; 512 IO::AIO::aio_unlink $path if $delete;
427 } 513 }
428 } 514 }
429 515
430 sub process_faceinfo { 516 sub process_faceinfo {
431 my ($dir, $file) = @_; 517 my ($dir, $file) = @_;
432 my $path = "$dir/$file"; 518 my $path = "$dir/$file";
433 519
434 my $data; 520 my $data;
435 if (0 > aio_load $path, $data) { 521 if (0 > aio_load $path, $data) {
436 warn "$path: $!, skipping.\n"; 522 warn "ERROR: $path: $!, skipping.\n";
437 return; 523 return;
438 } 524 }
439 525
440 for (split /\n/, $data) { 526 for (split /\n/, $data) {
441 chomp; 527 chomp;
442 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/; 528 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
443 # bg not used except for text clients 529 # bg not used except for text clients
444 530
445 utf8::decode $glyph; 531 utf8::decode $glyph;
446 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag 532 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag
533 $glyph =~ s/^"(.+)"$/$1/; # allow for ""-style quoting
447 534
448 $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet 535 $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet
449 536
450 (my $fgi = $COLOR{$fg}) 537 (my $fgi = $COLOR{$fg})
451 // warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n"; 538 // warn "ERROR: $path: $face specifies unknown foreground colour '$fg'.\n";
452 (my $bgi = $COLOR{$bg}) 539 (my $bgi = $COLOR{$bg})
453 // warn "WARNING: $path: $face specifies unknown background colour '$bg'.\n"; 540 // warn "ERROR: $path: $face specifies unknown background colour '$bg'.\n";
454 541
455 my $fi = $FACEINFO{$face} ||= { }; 542 my $fi = $FACEINFO{$face} ||= { };
456 $fi->{visibility} = $visibility * 1; 543 $fi->{visibility} = $visibility * 1;
457 $fi->{magicmap} = $fgi; # foreground colour becomes magicmap 544 $fi->{magicmap} = $fgi; # foreground colour becomes magicmap
458 545
459 $glyph .= " " if 2 > length $glyph; # TODO kanji 546 $glyph .= " " if 2 > length $glyph; # TODO kanji
547 die "glyph $face too long" if 2 < length $glyph;
460 548
461 $fi->{glyph} = ""; 549 $fi->{glyph} = "";
462 for (split //, $glyph, -1) { 550 for (split //, $glyph) {
463 utf8::encode $_; 551 utf8::encode $_;
464 $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_; 552 $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
465 } 553 }
466 } 554 }
467 } 555 }
… …
526 next if /^facings\s/; 614 next if /^facings\s/;
527 615
528 my $face = $_; 616 my $face = $_;
529 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates 617 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
530 618
531 my $info = $FACEINFO{$face} ||= { }; 619 # handle derived faces
620 if ($face =~ /^([^:]+):(.*)/) {
621 my ($type, $base) = ($1, $2);
622 push @{ $FACEINFO{$base}{derive} }, [$dir, $type];
623 }
624
532 $info->{arc} = $o; 625 $FACEINFO{$face}{arc} = $o;
533 626
534 next if $face =~ /^blank.x11$|^empty.x11$/; 627 next if $face =~ /^blank.x11$|^empty.x11$/;
535 } 628 }
536 629
537 if (my $smooth = delete $o->{smoothface}) { 630 if (my $smooth = delete $o->{smoothface}) {
… …
553 my ($dir, $file) = @_; 646 my ($dir, $file) = @_;
554 my $path = "$dir/$file"; 647 my $path = "$dir/$file";
555 648
556 my $trs; 649 my $trs;
557 if (0 > aio_load $path, $trs) { 650 if (0 > aio_load $path, $trs) {
558 warn "$path: $!, skipping.\n"; 651 warn "ERROR: $path: $!, skipping.\n";
559 return; 652 return;
560 } 653 }
561 654
562 $TRS .= $trs; 655 $TRS .= $trs;
563 } 656 }
… …
568 unless (exists $FILECACHE{$_[0]}) { 661 unless (exists $FILECACHE{$_[0]}) {
569 my $data; 662 my $data;
570 if (0 < aio_load $_[0], $data) { 663 if (0 < aio_load $_[0], $data) {
571 if ($_[1]) { 664 if ($_[1]) {
572 $data = eval { $_[1]->($data) }; 665 $data = eval { $_[1]->($data) };
573 warn "$_[0]: $@" if $@; 666 warn "ERROR: $_[0]: $@" if $@;
574 } 667 }
575 } 668 }
576 669
577 $FILECACHE{$_[0]} = $data; 670 $FILECACHE{$_[0]} = $data;
578 } 671 }
579 672
580 $FILECACHE{$_[0]} 673 $FILECACHE{$_[0]}
674 }
675
676 # convert an image and a palette to some indexed 2d-matrix structure
677 sub process_plt {
678 my ($base, $plt) = @_;
679
680 my ($w, $h) = imgsize "$base.png";
681
682 $w * $h
683 or die "$base.png: unable to identify correct size\n";
684
685 my @plt;
686 my %map;
687
688 for (split /\n/, $plt) {
689 next unless /\S/;
690 next if /^\s*#/;
691
692 /^([0-9a-fA-F]{3,6})\s*(.*?)\s*$/
693 or die "unparseable palette entry for $base.plt: $_";
694
695 my ($rgb, $name) = ($1, $2);
696
697 $rgb =~ s/^(.)(.)(.)$/$1$1$2$2$3$3/;
698
699 $map{pack "H*", $rgb} = chr @plt;
700 push @plt, $name;
701 }
702
703 make_file ["$base.plt", "$base.png"], "$base.tbl~", sub {
704 warn "building $base\n" if $VERBOSE >= 3;
705
706 fork_exec {
707 open my $png, "-|", $CONVERT, qw(-depth 8 --), "$base.png", "rgb:"
708 or die "$base.png: $!";
709
710 local $/;
711 $png = <$png>;
712
713 $w * $h * 3 == length $png
714 or die "$base.png: failed to read enough data from file\n";
715
716 $png =~ s/(...)/$map{$1}/ge;
717
718 $w * $h == length $png
719 or die "$base.png: failed to map all data - wrong palette?\n";
720
721 {
722 open my $fh, ">:raw", "$base.tbl~~"
723 or die "$base.tbl~~: $!";
724 syswrite $fh, $png;
725 }
726
727 rename "$base.tbl~~", "$base.tbl~";
728 };
729 };
730
731 0 <= aio_load "$base.tbl~", my $tbl
732 or die "$base.tbl~: $!";
733
734 IO::AIO::aio_unlink "$base.tbl~" unless $CACHE;
735
736 Compress::LZF::compress nfreeze {
737 w => $w,
738 h => $h,
739 plt => \@plt,
740 tbl => $tbl,
741 }
581 } 742 }
582 743
583 sub process_res { 744 sub process_res {
584 my ($dir, $file, $type) = @_; 745 my ($dir, $file, $type) = @_;
585 746
586 my $data;
587 aio_load "$dir/$file", $data; 747 0 <= aio_load "$dir/$file", my $data
748 or die "$dir/$file: $!";
588 749
589 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) }; 750 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
590 751
591 utf8::decode $dir; 752 utf8::decode $dir;
592 utf8::decode $file; 753 utf8::decode $file;
… …
609 "cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/", 770 "cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
610 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/", 771 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
611 "cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/", 772 "cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
612 "cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/", 773 "cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
613 })->{$meta->{license}} 774 })->{$meta->{license}}
614 || warn "$dir/$file: license tag '$meta->{license}' not found."; 775 || warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
615 } 776 }
616 777
617 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) { 778 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
618 ($meta->{author} = $1) =~ s/_/ /g; 779 ($meta->{author} = $1) =~ s/_/ /g;
619 } 780 }
620 781
621 $file =~ s/\.res$//; 782 $file =~ s/\.res$//;
622 $file =~ s/\.(ogg|wav|jpg|png)$//; 783 $file =~ s/\.(ogg|wav|jpg|png)$//;
623 784
624 substr $dir, 0, 1 + length $PATH, ""; 785 if ($file =~ s/\.plt$//) {
625 786 $data = process_plt "$dir/$file", $data;
626 if (my $filter = $meta->{cfutil_filter}) { 787 } elsif (my $filter = delete $meta->{cfutil_filter}) {
627 if ($filter eq "yaml2json") { 788 if ($filter eq "yaml2json") {
628 $data = JSON::XS::encode_json YAML::XS::Load $data; 789 $data = JSON::XS::encode_json YAML::XS::Load $data;
629 } elsif ($filter eq "json2json") { 790 } elsif ($filter eq "json2json") {
630 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); 791 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
631 } elsif ($filter eq "perl2json") { 792 } elsif ($filter eq "perl2json") {
632 $data = eval $data; die if $@; 793 $data = eval $data; die if $@;
633 $data = JSON::XS::encode_json $data; 794 $data = JSON::XS::encode_json $data;
634 } else { 795 } else {
635 warn "$dir/$file: unknown filter $filter, skipping\n"; 796 warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
636 }
637 } 797 }
798 }
799
800 substr $dir, 0, 1 + length $PATH, "";
638 801
639 $RESOURCE{"$dir/$file"} = { 802 $RESOURCE{"$dir/$file"} = {
640 type => (exists $meta->{type} ? delete $meta->{type} : $type), 803 type => (exists $meta->{type} ? delete $meta->{type} : $type),
641 data => $data, 804 data => $data,
642 %$meta ? (meta => $meta) : (), 805 %$meta ? (meta => $meta) : (),
… …
681 if ($file =~ /\.(jpg|png)$/) { 844 if ($file =~ /\.(jpg|png)$/) {
682 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE 845 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
683 } elsif ($file =~ /\.(res)$/) { 846 } elsif ($file =~ /\.(res)$/) {
684 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC 847 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
685 } else { 848 } else {
686 $c_any->put ([\&process_res, $path, $file, undef]); 849 $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
687 } 850 }
688 851
689 } elsif ($file =~ /\.png$/) { 852 } elsif ($file =~ /\.png$/) {
690 push @c_png, ["$path/$file", 0]; 853 $PNG{$file} = $path;
691 854
692 } elsif ($file =~ /\.faceinfo$/) { 855 } elsif ($file =~ /\.faceinfo$/) {
693 $c_any->put ([\&process_faceinfo, $path, $file]); 856 $c_any->put ([\&process_faceinfo, $path, $file]);
694 857
695 } elsif ($file =~ /\.trs$/) { 858 } elsif ($file =~ /\.trs$/) {
… …
748 "Unless you run verbosely, all following warning\n", 911 "Unless you run verbosely, all following warning\n",
749 "or error messages indicate serious problems.\n", 912 "or error messages indicate serious problems.\n",
750 "\n"; 913 "\n";
751 914
752 if (!-d "$path/treasures") { 915 if (!-d "$path/treasures") {
753 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 916 warn "FATAL: '$path' does not look like an arch directory ('treasures' directory is missing).\n";
754 exit 1 unless $FORCE; 917 exit 1 unless $FORCE;
755 } 918 }
756 919
757 print "start file scan, arc, any processing...\n" if $VERBOSE; 920 print "starting file scan, arc, any processing...\n" if $VERBOSE;
758 921
759 my @a_arc = map +(async \&process_arc), 1..2; 922 my @a_arc = map +(async \&process_arc), 1..2;
760 my @a_any = map +(async \&process_any), 1..4; 923 my @a_any = map +(async \&process_any), 1..4;
761 924
762 find_files $path; 925 find_files $path;
763 926
764 $c_arc->shutdown; 927 $c_arc->shutdown;
765 $c_any->shutdown; 928 $c_any->shutdown;
766 929
767 $_->join for @a_arc; # need to parse all archetypes before png processing 930 $_->join for @a_arc; # need to parse all archetypes before png processing
931 print "finished arc processing...\n" if $VERBOSE;
768 932
933 # fill png queue
934 for (keys %FACEINFO) {
935 # we only expect source pngs to exist for non-derived
936 # faces, i.e. no split tiles (+x+x) and no face derivates
937 # (xxx:)
938 /^[^:]+\....$/
939 or next;
940
941 my $seen;
942
943 if (exists $PNG{"$_.32x32.png"}) {
944 push @c_png, ["$PNG{\"$_.32x32.png\"}/$_.32x32.png"];
945 $seen = 1;
946 }
947 if (exists $PNG{"$_.64x64.png"}) {
948 push @c_png, ["$PNG{\"$_.64x64.png\"}/$_.64x64.png"];
949 $seen = 1;
950 }
951
952 warn "ERROR: $_: face not found, expect problems.\n"
953 unless $seen;
954 }
955
769 print "end arc, start png processing...\n" if $VERBOSE; 956 print "starting png processing...\n" if $VERBOSE;
770 957
771 # eight png crunchers work fine for my 4x smp machine 958 # eight png crunchers work fine for my 4x smp machine
772 my @a_png = map +(async \&process_png), 1..8; 959 my @a_png = map +(async \&process_png), 1..8;
773 960
774 print "end any processing...\n" if $VERBOSE;
775 $_->join for @a_any; 961 $_->join for @a_any;
776
777 print "end png processing...\n" if $VERBOSE; 962 print "finished any processing...\n" if $VERBOSE;
963
778 $_->join for @a_png; 964 $_->join for @a_png;
965 print "finished png processing...\n" if $VERBOSE;
779 966
780 print "scanning done, processing results...\n" if $VERBOSE; 967 print "scanning done, processing results...\n" if $VERBOSE;
781 { 968 {
782 # remove path prefix from editor_folder 969 # remove path prefix from editor_folder
783 $_->{editor_folder} =~ /^\x00/ 970 $_->{editor_folder} =~ /^\x00/
… …
801 delete @s{qw(_name more name name_pl)}; 988 delete @s{qw(_name more name name_pl)};
802 %$o = ( %s, %$o ); 989 %$o = ( %s, %$o );
803 ++$progress; 990 ++$progress;
804 } 991 }
805 } else { 992 } else {
806 warn "WARNING: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n"; 993 warn "ERROR: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
807 delete $ARC{$o->{_name}}; 994 delete $ARC{$o->{_name}};
808 } 995 }
809 } 996 }
810 } 997 }
811 998
… …
848 } 1035 }
849 1036
850 { 1037 {
851 print "processing facedata...\n" if $VERBOSE; 1038 print "processing facedata...\n" if $VERBOSE;
852 while (my ($k, $v) = each %FACEINFO) { 1039 while (my ($k, $v) = each %FACEINFO) {
853 length $v->{data32} or warn "WARNING: face '$k' has no png32. this will not work (shoddy gcfclient will crash of course).\n"; 1040 length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
854 length $v->{data64} or warn "WARNING: face '$k' has no png64. this will not work very well.\n"; 1041 length $v->{data64} or warn "ERROR: face '$k' has no png64 - this will not work.\n";
855 1042
856 make_hash $k, $v->{data32}, $v->{hash32}; 1043 make_hash $k, $v->{data32}, $v->{hash32};
857 make_hash $k, $v->{data64}, $v->{hash64}; 1044 make_hash $k, $v->{data64}, $v->{hash64};
858 1045
859 #length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n"; 1046 #length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
860 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n"; 1047 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
861 1048
862 $v->{glyph} // warn "WARNING: face '$k' has glyph."; 1049 $v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
863 $v->{visibility} // warn "WARNING: face '$k' has no visibility info, missing faceinfo entry?\n"; 1050 $v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
864 $v->{magicmap} // warn "WARNING: face '$k' has foreground colour."; 1051 $v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
865 1052
866 delete @$v{qw(arc stem)}; # not used by the server 1053 delete @$v{qw(arc stem derive)}; # not used by the server
867 } 1054 }
868 1055
869 print "processing resources...\n" if $VERBOSE; 1056 print "processing resources...\n" if $VERBOSE;
870 my $enc = JSON::XS->new->utf8->canonical->relaxed; 1057 my $enc = JSON::XS->new->utf8->canonical->relaxed;
871 while (my ($k, $v) = each %RESOURCE) { 1058 while (my ($k, $v) = each %RESOURCE) {
… …
910 version => 2, 1097 version => 2,
911 faceinfo => \%FACEINFO, 1098 faceinfo => \%FACEINFO,
912 animinfo => \%ANIMINFO, 1099 animinfo => \%ANIMINFO,
913 resource => \%RESOURCE, 1100 resource => \%RESOURCE,
914 }; 1101 };
915
916 } 1102 }
917 1103
918 print "committing files...\n" if $VERBOSE; 1104 print "committing files...\n" if $VERBOSE;
919 1105
920 for (qw(archetypes facedata treasures), @COMMIT) { 1106 for (qw(archetypes facedata treasures), @COMMIT) {

Diff Legend

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