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.104 by root, Sat Oct 16 22:12:18 2010 UTC vs.
Revision 1.120 by root, Wed Jan 4 03:22:28 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" };
59
60sub WRITE_FACEINFO() { 0 }
61 62
62sub usage { 63sub usage {
63 warn <<EOF; 64 warn <<EOF;
64Usage: cfutil [-v] [-q] [--force] [--cache] 65Usage: cfutil [-v] [-q] [--force] [--cache]
65 [--install-arch path] 66 [--install-arch path]
… …
106 khaki => 12, 107 khaki => 12,
107); 108);
108 109
109END { system "rm", "-rf", $TMPDIR } 110END { system "rm", "-rf", $TMPDIR }
110 111
111my $s_INT = EV::signal INT => sub { exit 1 }; 112my $s_INT = AE::signal INT => sub { exit 1 };
112my $s_TERM = EV::signal TERM => sub { exit 1 }; 113my $s_TERM = AE::signal TERM => sub { exit 1 };
113 114
114our %hash; 115our %hash;
115 116
116# 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
117sub make_hash($\$\$;$) { 118sub make_hash($\$\$;$) {
118 my ($id, $dataref, $hashref, $clen) = @_; 119 my ($id, $dataref, $hashref, $clen) = @_;
119 120
120 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 4; 121 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 5;
121 122
122 if (exists $hash{$hash}) { 123 if (exists $hash{$hash}) {
123 # hash collision, but some files are simply identical 124 # hash collision, but some files are simply identical
124 if (${$hash{$hash}[1]} ne $$dataref) { 125 if (${$hash{$hash}[1]} ne $$dataref) {
125 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";
126 exit 1; 127 exit 1;
127 } else { 128 } else {
128 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;
129 } 130 }
130 } 131 }
131 $hash{$hash} = [$id, $dataref, $hashref]; 132 $hash{$hash} = [$id, $dataref, $hashref];
132 133
133 $$hashref = $hash; 134 $$hashref = $hash;
134} 135}
135 136
137sub optipng($) {
138 system $OPTIPNG, "-o5", "-i0", "-q", $_[0];
139 die "$_[0] has zero size, aborting." unless -s $_[0];
140}
141
136mkdir $TMPDIR, 0700 142mkdir $TMPDIR, 0700
137 or die "$TMPDIR: $!"; 143 or die "$TMPDIR: $!";
138 144
139sub fork_sub(&) { 145sub fork_exec(&) {
140 my ($cb) = @_; 146 my ($cb) = @_;
141 147
142 if (my $pid = fork) { 148 if (my $pid = fork) {
143 my $current = $Coro::current; 149 my $current = $Coro::current;
144 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); 150 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
… …
149 warn $@; 155 warn $@;
150 POSIX::_exit 1; 156 POSIX::_exit 1;
151 } 157 }
152} 158}
153 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
154sub inst_maps($) { 189sub inst_maps($) {
155 my (undef, $path) = @_; 190 my (undef, $path) = @_;
156 191
157 print "\nInstalling '$path' to '$DATADIR/maps'\n\n"; 192 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
158 193
159 if (!-f "$path/regions") { 194 if (!-f "$path/regions") {
160 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";
161 exit 1 unless $FORCE; 196 exit 1 unless $FORCE;
162 } 197 }
163 198
164 system $RSYNC, "-av", "--chmod=u=rwX,go=rX", 199 system $RSYNC, "-av", "--chmod=u=rwX,go=rX",
165 "$path/.", "$DATADIR/maps/.", 200 "$path/.", "$DATADIR/maps/.",
166 "--exclude", "CVS", "--exclude", "/world-precomposed", 201 "--exclude", "CVS", "--exclude", "/world-precomposed",
167 "--delete", "--delete-excluded" 202 "--delete", "--delete-excluded"
168 and die "map installation failed.\n"; 203 and die "map installation failed.\n";
169 204
170 print "maps installed successfully.\n"; 205 print "maps installed successfully.\n";
171}
172
173{
174 no utf8; # == values are utf-8 encoded
175
176 our @WALL_SUFFIX = qw(⬤ ╹ ╺ ┗ ╻ ┃ ┏ ┣ ╸ ┛ ━ ┻ ┓ ┫ ┳ ╋);
177
178 # used to create crude text glyphs for text-based clients
179 sub autoglyph {
180 my ($stem, $face) = @_;
181
182 if ($stem =~ /^wall\/|Nimwall/) {
183 return $WALL_SUFFIX[hex $1]
184 if $stem =~ /(_[0-9A-F]).x11/;
185
186 "█"
187
188 } elsif ($stem =~ /^traps\//) {
189 "☠"
190
191 } elsif ($stem =~ /^armour\/shield/) {
192 "Ø"
193
194 } elsif ($stem =~ /^armour\//) {
195 "A"
196
197 } elsif ($stem =~ /^weapon\//) {
198 "†"
199
200 } elsif ($stem =~ /^readable\//) {
201 "✉"
202
203 } elsif ($stem =~ /^river\//) {
204 "~"
205
206 } elsif ($stem =~ /^floor\/|^ground\/|Nimfloor/) {
207 "·"
208
209 } elsif ($stem =~ /^spells\//) {
210 "!"
211
212 } elsif ($stem =~ /^exit\//) {
213 "⎆"
214
215 } elsif ($stem =~ /^construct\//) {
216 "⌂"
217
218 } elsif ($stem =~ /^player\//) {
219 "\@"
220
221 } elsif ($stem =~ /^(?:monster|misc|class|connect|gods|indoor|inorganic|mining|music|skills).*\/(.)/) {
222 $1
223
224 } else {
225 substr $stem, 0, 1
226 }
227 }
228} 206}
229 207
230{ 208{
231 our %ANIMINFO; 209 our %ANIMINFO;
232 our %FACEINFO; 210 our %FACEINFO;
233 our %RESOURCE; 211 our %RESOURCE;
234 our @ARC; 212 our @ARC;
235 our %ARC; 213 our %ARC;
236 our $TRS; 214 our $TRS;
215 our %PNG;
237 our $NFILE; 216 our $NFILE;
238 our $PATH; 217 our $PATH;
239 218
240 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 219 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
241 220
… …
258 my $png; 237 my $png;
259 aio_lstat $path; 238 aio_lstat $path;
260 my ($size, $mtime) = (stat _)[7,9]; 239 my ($size, $mtime) = (stat _)[7,9];
261 240
262 if (0 > aio_load $path, $png) { 241 if (0 > aio_load $path, $png) {
263 warn "$path: $!, skipping.\n"; 242 warn "ERROR: $path: $!, skipping.\n";
264 next; 243 next;
265 } 244 }
266 245
267 my $stem = $path; 246 my $stem = $path;
268 my $T; 247 my $T;
… …
270 if ($stem =~ s/\.32x32\.png~?$//) { 249 if ($stem =~ s/\.32x32\.png~?$//) {
271 $T = 32; 250 $T = 32;
272 } elsif ($stem =~ s/\.64x64\.png~?$//) { 251 } elsif ($stem =~ s/\.64x64\.png~?$//) {
273 $T = 64; 252 $T = 64;
274 } else { 253 } else {
275 warn "$path: weird filename, skipping.\n"; 254 warn "ERROR: $path: weird filename, skipping.\n";
276 next; 255 next;
277 } 256 }
278 257
279 # quickly extract width and height of the (necessarily PNG) image 258 # quickly extract width and height of the (necessarily PNG) image
280 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) { 259 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
281 warn "$path: not a recognized png file, skipping.\n"; 260 warn "ERROR: $path: not a recognized png file, skipping.\n";
282 next; 261 next;
283 } 262 }
284 263
285 my ($w, $h) = unpack "NN", $1; 264 my ($w, $h) = unpack "NN", $1;
286 265
287 if ($w < $T || $h < $T) { 266 if ($w < $T || $h < $T) {
288 warn "$path: too small ($w $h), skipping.\n"; 267 warn "ERROR: $path: too small ($w $h), skipping.\n";
289 next; 268 next;
290 } 269 }
291 270
292 if ($w % $T || $h % $T) { 271 if ($w % $T || $h % $T) {
293 warn "$path: weird png size ($w $h), skipping.\n"; 272 warn "ERROR: $path: weird png size ($w $h), skipping.\n";
294 next; 273 next;
295 } 274 }
296 275
297 (my $base = $stem) =~ s/^.*\///; 276 (my $base = $stem) =~ s/^.*\///;
298 277
… …
307 unless ($path =~ /~$/) { 286 unless ($path =~ /~$/) {
308 # possibly enlarge 287 # possibly enlarge
309 if (0 > aio_stat "$stem.64x64.png") { 288 if (0 > aio_stat "$stem.64x64.png") {
310 my $other = "$stem.64x64.png~"; 289 my $other = "$stem.64x64.png~";
311 290
312 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 291 make_file $path, $other, sub {
313 fork_sub { 292 fork_exec {
314 my $CROP; 293 my $CROP;
315 my $SRC = "png:\Q$path\E"; 294 my $SRC = "png:\Q$path\E";
316 295
317 my $is_floor = $arc->{is_floor}; 296 my $is_floor = $arc->{is_floor};
318 my $is_wall = 0; 297 my $is_wall = 0;
… …
372 351
373 system "convert -depth 8 $SRC rgba:-" 352 system "convert -depth 8 $SRC rgba:-"
374 . "| $exec_prefix/bin/cfhq2xa $w $h 0" 353 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
375 . "| 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~"
376 and die "convert/cfhq2xa pipeline error: status $? ($!)"; 355 and die "convert/cfhq2xa pipeline error: status $? ($!)";
377 system $OPTIPNG, "-i0", "-q", "$other~"; 356 optipng "$other~";
378 die "$other~ has zero size, aborting." unless -s "$other~";
379 rename "$other~", $other; 357 rename "$other~", $other;
380 }; 358 };
381 } 359 };
382 360
383 push @c_png, [$other, !$CACHE]; 361 push @c_png, [$other, !$CACHE];
384 } 362 }
385 363
386 # possibly scale down 364 # possibly scale down
387 if (0 > aio_stat "$stem.32x32.png") { 365 if (0 > aio_stat "$stem.32x32.png") {
388 my $other = "$stem.32x32.png~"; 366 my $other = "$stem.32x32.png~";
389 367
390 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 368 make_file $path, $other, sub {
391 fork_sub { 369 fork_exec {
392 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~";
393 system $OPTIPNG, "-i0", "-q", "$other~"; 371 optipng "$other~";
394 372
395 # reduce smoothfaces >10000 bytes 373 # reduce smoothfaces >10000 bytes
396 # obsolete, no longer required 374 # obsolete, no longer required
397 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) { 375 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
398 my $ncolor = 256; 376 my $ncolor = 256;
399 while () { 377 while () {
400 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E"; 378 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
401 system $OPTIPNG, "-i0", "-q", "$other~~"; 379 optipng "$other~~";
402 last if 10000 > -s "$other~~"; 380 last if 10000 > -s "$other~~";
403 $ncolor = int $ncolor * 0.9; 381 $ncolor = int $ncolor * 0.9;
404 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes"; 382 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
405 } 383 }
406 384
… …
411 } 389 }
412 390
413 die "$other~ has zero size, aborting." unless -s "$other~"; 391 die "$other~ has zero size, aborting." unless -s "$other~";
414 rename "$other~", $other; 392 rename "$other~", $other;
415 }; 393 };
416 } 394 };
417 395
418 #warn "scaled down $path to $other\n";#d# 396 #warn "scaled down $path to $other\n";#d#
419 push @c_png, [$other, !$CACHE]; 397 push @c_png, [$other, !$CACHE];
420 } 398 }
421 } 399 }
422 400
423 (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 }
424 452
425 # split all bigfaces, but avoid smoothfaces (*_S) 453 # split all bigfaces, but avoid smoothfaces (*_S)
426 if (($w > $T || $h > $T) && $face !~ /_S\./) { 454 if (($w > $T || $h > $T) && $face !~ /_S\./) {
427 # split 455 # split
428 my @tile; 456 my @tile;
… …
433 push @tile, [$x, $y, $file, (stat _)[9]]; 461 push @tile, [$x, $y, $file, (stat _)[9]];
434 } 462 }
435 } 463 }
436 464
437 my $mtime = (lstat $path)[9]; 465 my $mtime = (lstat $path)[9];
438 my @todo = grep { $_->[3] <= $mtime } @tile; 466 my @todo = grep { $_->[3] < $mtime } @tile;
439 if (@todo) { 467 if (@todo) {
440 fork_sub { 468 fork_exec {
441 open my $convert, "|-", $CONVERT, 469 open my $convert, "|-", $CONVERT,
442 "png:-", 470 "png:-",
443 (map { 471 (map {
444 ( 472 (
445 "(", 473 "(",
… …
458 print $convert $png; 486 print $convert $png;
459 close $convert; 487 close $convert;
460 488
461 # pass 2, optimise, and rename 489 # pass 2, optimise, and rename
462 for (@todo) { 490 for (@todo) {
463 system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~"; 491 optipng "$_->[2]~";
464 die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
465 rename "$_->[2]~", $_->[2]; 492 rename "$_->[2]~", $_->[2];
466 } 493 }
467 }; 494 };
468 } 495 }
469 496
… …
480 } else { 507 } else {
481 # use as-is (either small, use smooth) 508 # use as-is (either small, use smooth)
482 commit_png $stem, $face, $png, $T; 509 commit_png $stem, $face, $png, $T;
483 } 510 }
484 511
485 aio_unlink $path if $delete; 512 IO::AIO::aio_unlink $path if $delete;
486 } 513 }
487 } 514 }
488 515
489 sub process_faceinfo { 516 sub process_faceinfo {
490 my ($dir, $file) = @_; 517 my ($dir, $file) = @_;
491 my $path = "$dir/$file"; 518 my $path = "$dir/$file";
492 519
493 my $data; 520 my $data;
494 if (0 > aio_load $path, $data) { 521 if (0 > aio_load $path, $data) {
495 warn "$path: $!, skipping.\n"; 522 warn "ERROR: $path: $!, skipping.\n";
496 return; 523 return;
497 } 524 }
498 525
499 for (split /\n/, $data) { 526 for (split /\n/, $data) {
527 chomp;
500 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/; 528 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
529 # bg not used except for text clients
501 530
531 utf8::decode $glyph;
502 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag 532 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag
533 $glyph =~ s/^"(.+)"$/$1/; # allow for ""-style quoting
534
535 $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet
503 536
504 (my $fgi = $COLOR{$fg}) 537 (my $fgi = $COLOR{$fg})
505 // warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n"; 538 // warn "ERROR: $path: $face specifies unknown foreground colour '$fg'.\n";
506 (my $bgi = $COLOR{$bg}) 539 (my $bgi = $COLOR{$bg})
507 // warn "WARNING: $path: $face specifies unknown background colour '$bg'.\n"; 540 // warn "ERROR: $path: $face specifies unknown background colour '$bg'.\n";
508 541
509 my $fi = $FACEINFO{$face} ||= { }; 542 my $fi = $FACEINFO{$face} ||= { };
510 $fi->{visibility} = $visibility * 1; 543 $fi->{visibility} = $visibility * 1;
511 $fi->{magicmap} = $fgi; # foreground colour becomes magicmap 544 $fi->{magicmap} = $fgi; # foreground colour becomes magicmap
545
546 $glyph .= " " if 2 > length $glyph; # TODO kanji
547 die "glyph $face too long" if 2 < length $glyph;
548
549 $fi->{glyph} = "";
550 for (split //, $glyph) {
551 utf8::encode $_;
512 $fi->{glyph} = (chr $fgi) . (chr $bgi) . $glyph; 552 $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
513 #$fi->{glyph} = (chr $fgi) . $glyph;#d#TOOD remove 553 }
514 # bg not used except for text clients
515 } 554 }
516 } 555 }
517 556
518 sub process_arc { 557 sub process_arc {
519 while (my ($dir, $file) = @{ $c_arc->get }) { 558 while (my ($dir, $file) = @{ $c_arc->get }) {
… …
575 next if /^facings\s/; 614 next if /^facings\s/;
576 615
577 my $face = $_; 616 my $face = $_;
578 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates 617 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
579 618
580 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
581 $info->{arc} = $o; 625 $FACEINFO{$face}{arc} = $o;
582 626
583 next if $face =~ /^blank.x11$|^empty.x11$/; 627 next if $face =~ /^blank.x11$|^empty.x11$/;
584 } 628 }
585 629
586 if (my $smooth = delete $o->{smoothface}) { 630 if (my $smooth = delete $o->{smoothface}) {
… …
602 my ($dir, $file) = @_; 646 my ($dir, $file) = @_;
603 my $path = "$dir/$file"; 647 my $path = "$dir/$file";
604 648
605 my $trs; 649 my $trs;
606 if (0 > aio_load $path, $trs) { 650 if (0 > aio_load $path, $trs) {
607 warn "$path: $!, skipping.\n"; 651 warn "ERROR: $path: $!, skipping.\n";
608 return; 652 return;
609 } 653 }
610 654
611 $TRS .= $trs; 655 $TRS .= $trs;
612 } 656 }
… …
617 unless (exists $FILECACHE{$_[0]}) { 661 unless (exists $FILECACHE{$_[0]}) {
618 my $data; 662 my $data;
619 if (0 < aio_load $_[0], $data) { 663 if (0 < aio_load $_[0], $data) {
620 if ($_[1]) { 664 if ($_[1]) {
621 $data = eval { $_[1]->($data) }; 665 $data = eval { $_[1]->($data) };
622 warn "$_[0]: $@" if $@; 666 warn "ERROR: $_[0]: $@" if $@;
623 } 667 }
624 } 668 }
625 669
626 $FILECACHE{$_[0]} = $data; 670 $FILECACHE{$_[0]} = $data;
627 } 671 }
628 672
629 $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 }
630 } 742 }
631 743
632 sub process_res { 744 sub process_res {
633 my ($dir, $file, $type) = @_; 745 my ($dir, $file, $type) = @_;
634 746
635 my $data;
636 aio_load "$dir/$file", $data; 747 0 <= aio_load "$dir/$file", my $data
748 or die "$dir/$file: $!";
637 749
638 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) };
639 751
640 utf8::decode $dir; 752 utf8::decode $dir;
641 utf8::decode $file; 753 utf8::decode $file;
… …
649 $meta = { 761 $meta = {
650 %{ $meta->{"" } || {} }, 762 %{ $meta->{"" } || {} },
651 %{ $meta->{$file} || {} }, 763 %{ $meta->{$file} || {} },
652 }; 764 };
653 765
654 if ($meta->{license} =~ s/^#//) { 766 if (exists $meta->{license} && $meta->{license} =~ s/^#//) { # exists == avoid autovivification
655 $meta->{license} = ({ 767 $meta->{license} = ({
656 "pd" => "Public Domain", 768 "pd" => "Public Domain",
657 "gpl" => "GNU General Public License, version 3.0 or any later", 769 "gpl" => "GNU General Public License, version 3.0 or any later",
658 "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/",
659 "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/",
660 "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/",
661 "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/",
662 })->{$meta->{license}} 774 })->{$meta->{license}}
663 || warn "$dir/$file: license tag '$meta->{license}' not found."; 775 || warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
664 } 776 }
665 777
666 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/(.*)$%) {
667 ($meta->{author} = $1) =~ s/_/ /g; 779 ($meta->{author} = $1) =~ s/_/ /g;
668 } 780 }
669 781
670 $file =~ s/\.res$//; 782 $file =~ s/\.res$//;
671 $file =~ s/\.(ogg|wav|jpg|png)$//; 783 $file =~ s/\.(ogg|wav|jpg|png)$//;
672 784
673 substr $dir, 0, 1 + length $PATH, ""; 785 if ($file =~ s/\.plt$//) {
674 786 $data = process_plt "$dir/$file", $data;
675 if (my $filter = $meta->{cfutil_filter}) { 787 } elsif (my $filter = delete $meta->{cfutil_filter}) {
676 if ($filter eq "yaml2json") { 788 if ($filter eq "yaml2json") {
677 $data = JSON::XS::encode_json YAML::XS::Load $data; 789 $data = JSON::XS::encode_json YAML::XS::Load $data;
678 } elsif ($filter eq "json2json") { 790 } elsif ($filter eq "json2json") {
679 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); 791 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
680 } elsif ($filter eq "perl2json") { 792 } elsif ($filter eq "perl2json") {
681 $data = eval $data; die if $@; 793 $data = eval $data; die if $@;
682 $data = JSON::XS::encode_json $data; 794 $data = JSON::XS::encode_json $data;
683 } else { 795 } else {
684 warn "$dir/$file: unknown filter $filter, skipping\n"; 796 warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
685 }
686 } 797 }
798 }
799
800 substr $dir, 0, 1 + length $PATH, "";
687 801
688 $RESOURCE{"$dir/$file"} = { 802 $RESOURCE{"$dir/$file"} = {
689 type => (exists $meta->{type} ? delete $meta->{type} : $type), 803 type => (exists $meta->{type} ? delete $meta->{type} : $type),
690 data => $data, 804 data => $data,
691 %$meta ? (meta => $meta) : (), 805 %$meta ? (meta => $meta) : (),
… …
730 if ($file =~ /\.(jpg|png)$/) { 844 if ($file =~ /\.(jpg|png)$/) {
731 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE 845 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
732 } elsif ($file =~ /\.(res)$/) { 846 } elsif ($file =~ /\.(res)$/) {
733 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC 847 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
734 } else { 848 } else {
735 $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
736 } 850 }
737 851
738 } elsif ($file =~ /\.png$/) { 852 } elsif ($file =~ /\.png$/) {
739 push @c_png, ["$path/$file", 0]; 853 $PNG{$file} = $path;
740 854
741 } elsif ($file =~ /\.faceinfo$/) { 855 } elsif ($file =~ /\.faceinfo$/) {
742 $c_any->put ([\&process_faceinfo, $path, $file]); 856 $c_any->put ([\&process_faceinfo, $path, $file]);
743 857
744 } elsif ($file =~ /\.trs$/) { 858 } elsif ($file =~ /\.trs$/) {
… …
797 "Unless you run verbosely, all following warning\n", 911 "Unless you run verbosely, all following warning\n",
798 "or error messages indicate serious problems.\n", 912 "or error messages indicate serious problems.\n",
799 "\n"; 913 "\n";
800 914
801 if (!-d "$path/treasures") { 915 if (!-d "$path/treasures") {
802 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";
803 exit 1 unless $FORCE; 917 exit 1 unless $FORCE;
804 } 918 }
805 919
806 print "start file scan, arc, any processing...\n" if $VERBOSE; 920 print "starting file scan, arc, any processing...\n" if $VERBOSE;
807 921
808 my @a_arc = map +(async \&process_arc), 1..2; 922 my @a_arc = map +(async \&process_arc), 1..2;
809 my @a_any = map +(async \&process_any), 1..4; 923 my @a_any = map +(async \&process_any), 1..4;
810 924
811 find_files $path; 925 find_files $path;
812 926
813 $c_arc->shutdown; 927 $c_arc->shutdown;
814 $c_any->shutdown; 928 $c_any->shutdown;
815 929
816 $_->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;
817 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
818 print "end arc, start png processing...\n" if $VERBOSE; 956 print "starting png processing...\n" if $VERBOSE;
819 957
820 # eight png crunchers work fine for my 4x smp machine 958 # eight png crunchers work fine for my 4x smp machine
821 my @a_png = map +(async \&process_png), 1..8; 959 my @a_png = map +(async \&process_png), 1..8;
822 960
823 print "end any processing...\n" if $VERBOSE;
824 $_->join for @a_any; 961 $_->join for @a_any;
825
826 print "end png processing...\n" if $VERBOSE; 962 print "finished any processing...\n" if $VERBOSE;
963
827 $_->join for @a_png; 964 $_->join for @a_png;
965 print "finished png processing...\n" if $VERBOSE;
828 966
829 print "scanning done, processing results...\n" if $VERBOSE; 967 print "scanning done, processing results...\n" if $VERBOSE;
830 { 968 {
831 # remove path prefix from editor_folder 969 # remove path prefix from editor_folder
832 $_->{editor_folder} =~ /^\x00/ 970 $_->{editor_folder} =~ /^\x00/
… …
850 delete @s{qw(_name more name name_pl)}; 988 delete @s{qw(_name more name name_pl)};
851 %$o = ( %s, %$o ); 989 %$o = ( %s, %$o );
852 ++$progress; 990 ++$progress;
853 } 991 }
854 } else { 992 } else {
855 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";
856 delete $ARC{$o->{_name}}; 994 delete $ARC{$o->{_name}};
857 } 995 }
858 } 996 }
859 } 997 }
860 998
… …
887 open my $fh, ">:utf8", "$DATADIR/archetypes~" 1025 open my $fh, ">:utf8", "$DATADIR/archetypes~"
888 or die "$DATADIR/archetypes~: $!"; 1026 or die "$DATADIR/archetypes~: $!";
889 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC]; 1027 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
890 } 1028 }
891 1029
892 if (WRITE_FACEINFO) {
893 my @table;
894 for my $face (sort keys %FACEINFO) {
895 my $v = $FACEINFO{$face};
896 (my $xf = $face) =~ s/\+\d+\+\d+$//;
897
898 $v->{magicmap} //= $FACEINFO{$xf}{magicmap};
899 $v->{glyph} //= $FACEINFO{$xf}{glyph};
900
901 $v->{magicmap} =~ y/A-Z_\-/a-z/d;
902
903 delete $v->{glyph} if $v->{glyph} =~ /^\?./;
904
905 my $stem = $v->{stem};
906 $v->{glyph} = $v->{glyph} // ("?" . (autoglyph $stem, $v));
907
908 push @table, [$face, $v->{visibility} || 0, $v->{magicmap} || "none", "none ", $v->{glyph}];
909 }
910 use Text::Table;
911 my $tb = new Text::Table undef, { align => "num" }, undef, undef, undef;
912 $tb->load (@table);
913 open my $fh, ">:raw", "default.faceinfo"or die;
914 print $fh $tb;
915 print "default.faceinfo written, exiting.\n";
916 exit 77;
917 }
918
919 { 1030 {
920 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE; 1031 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
921 open my $fh, ">:utf8", "$DATADIR/treasures~" 1032 open my $fh, ">:utf8", "$DATADIR/treasures~"
922 or die "$DATADIR/treasures~: $!"; 1033 or die "$DATADIR/treasures~: $!";
923 print $fh $TRS; 1034 print $fh $TRS;
924 } 1035 }
925 1036
926 { 1037 {
927 print "processing facedata...\n" if $VERBOSE; 1038 print "processing facedata...\n" if $VERBOSE;
928 while (my ($k, $v) = each %FACEINFO) { 1039 while (my ($k, $v) = each %FACEINFO) {
929 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";
930 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";
931 1042
932 make_hash $k, $v->{data32}, $v->{hash32}; 1043 make_hash $k, $v->{data32}, $v->{hash32};
933 make_hash $k, $v->{data64}, $v->{hash64}; 1044 make_hash $k, $v->{data64}, $v->{hash64};
934 1045
935 #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";
936 #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";
937 1048
938 exists $v->{visibility} 1049 $v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
939 or 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";
1051 $v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
940 1052
941 my $stem = delete $v->{stem}; 1053 delete @$v{qw(arc stem derive)}; # not used by the server
942 $v->{glyph} // warn "WARNING: face '$k' has glyph, cannot autoglyph at the moment.";
943 #$v->{glyph} //= autoglyph $stem, $v;
944
945 delete $v->{arc};
946 } 1054 }
947 1055
948 print "processing resources...\n" if $VERBOSE; 1056 print "processing resources...\n" if $VERBOSE;
949 my $enc = JSON::XS->new->utf8->canonical->relaxed; 1057 my $enc = JSON::XS->new->utf8->canonical->relaxed;
950 while (my ($k, $v) = each %RESOURCE) { 1058 while (my ($k, $v) = each %RESOURCE) {
… …
989 version => 2, 1097 version => 2,
990 faceinfo => \%FACEINFO, 1098 faceinfo => \%FACEINFO,
991 animinfo => \%ANIMINFO, 1099 animinfo => \%ANIMINFO,
992 resource => \%RESOURCE, 1100 resource => \%RESOURCE,
993 }; 1101 };
994
995 } 1102 }
996 1103
997 print "committing files...\n" if $VERBOSE; 1104 print "committing files...\n" if $VERBOSE;
998 1105
999 for (qw(archetypes facedata treasures), @COMMIT) { 1106 for (qw(archetypes facedata treasures), @COMMIT) {

Diff Legend

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