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.73 by root, Mon Oct 26 11:31:39 2009 UTC vs.
Revision 1.120 by root, Wed Jan 4 03:22:28 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 File::Temp; 39use File::Temp;
18use POSIX (); 40use POSIX ();
19use Carp; 41use Carp;
20 42
21use Coro::EV;
22use AnyEvent;
23use YAML::XS (); 43use YAML::XS ();
44use Digest::MD5 ();
45use Storable ();
24use JSON::XS (); 46use JSON::XS ();
25use IO::AIO (); 47use IO::AIO ();
48use Compress::LZF ();
26 49
50use AnyEvent;
27use Coro 5.12; 51use Coro 5.12;
52use Coro::EV;
28use Coro::AIO; 53use Coro::AIO;
29use Coro::Util; 54use Coro::Util;
30use Coro::Channel; 55use Coro::Channel;
56use Coro::AnyEvent;
31use Coro::Storable; $Storable::canonical = 1; 57use Coro::Storable; $Storable::canonical = 1;
32 58
33use Deliantra; 59use Deliantra;
34 60
35$SIG{QUIT} = sub { Carp::cluck "QUIT" }; 61$SIG{QUIT} = sub { Carp::cluck "QUIT" };
… …
51my $VERBOSE = 1; 77my $VERBOSE = 1;
52my $CACHE = 0; 78my $CACHE = 0;
53my $FORCE; 79my $FORCE;
54my $TMPDIR = "/tmp/cfutil$$~"; 80my $TMPDIR = "/tmp/cfutil$$~";
55my $TMPFILE = "aaaa0"; 81my $TMPFILE = "aaaa0";
82my @COMMIT;
56 83
57our %COLOR = ( 84our %COLOR = (
85 # original cf colours
58 black => 0, 86 black => 0,
59 white => 1, 87 white => 1,
60 navy => 2, 88 navy => 2, # "dark blue"
61 red => 3, 89 red => 3,
62 orange => 4, 90 orange => 4,
63 blue => 5, 91 blue => 5, # "light blue"
64 darkorange => 6, 92 darkorange => 6,
65 green => 7, 93 green => 7,
66 lightgreen => 8, 94 lightgreen => 8,
67 grey => 9, 95 grey => 9,
96 brown => 10, # "yellow"
97 gold => 11, # "light yellow"
98 tan => 12, # yellowish gray
99
100 # new for deliantra
68 brown => 10, 101 none => 13,
102
103 # compatibility to existing archetypes
104 lightblue => 5,
69 gold => 11, 105 gray => 9,
106 yellow => 11,
70 tan => 12, 107 khaki => 12,
71); 108);
72 109
73END { system "rm", "-rf", $TMPDIR } 110END { system "rm", "-rf", $TMPDIR }
74 111
75my $s_INT = EV::signal INT => sub { exit 1 }; 112my $s_INT = AE::signal INT => sub { exit 1 };
76my $s_TERM = EV::signal TERM => 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}
77 141
78mkdir $TMPDIR, 0700 142mkdir $TMPDIR, 0700
79 or die "$TMPDIR: $!"; 143 or die "$TMPDIR: $!";
80 144
81sub fork_sub(&) { 145sub fork_exec(&) {
82 my ($cb) = @_; 146 my ($cb) = @_;
83 147
84 if (my $pid = fork) { 148 if (my $pid = fork) {
85 my $current = $Coro::current; 149 my $current = $Coro::current;
86 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); 150 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
… …
91 warn $@; 155 warn $@;
92 POSIX::_exit 1; 156 POSIX::_exit 1;
93 } 157 }
94} 158}
95 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
96sub inst_maps($) { 189sub inst_maps($) {
97 my (undef, $path) = @_; 190 my (undef, $path) = @_;
98 191
99 print "\nInstalling '$path' to '$DATADIR/maps'\n\n"; 192 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
100 193
101 if (!-f "$path/regions") { 194 if (!-f "$path/regions") {
102 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";
103 exit 1 unless $FORCE; 196 exit 1 unless $FORCE;
104 } 197 }
105 198
106 system $RSYNC, "-av", "--chmod=u=rwX,go=rX", 199 system $RSYNC, "-av", "--chmod=u=rwX,go=rX",
107 "$path/.", "$DATADIR/maps/.", 200 "$path/.", "$DATADIR/maps/.",
… …
117 our %FACEINFO; 210 our %FACEINFO;
118 our %RESOURCE; 211 our %RESOURCE;
119 our @ARC; 212 our @ARC;
120 our %ARC; 213 our %ARC;
121 our $TRS; 214 our $TRS;
215 our %PNG;
122 our $NFILE; 216 our $NFILE;
123 our $PATH; 217 our $PATH;
124 218
125 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 219 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
126 220
127 our $c_arc = new Coro::Channel; 221 our $c_arc = new Coro::Channel;
128 our $c_trs = new Coro::Channel; 222 our $c_any = new Coro::Channel;
129 our $c_res = new Coro::Channel;
130 223
131 our @c_png; 224 our @c_png;
132 225
133 sub commit_png($$$) { 226 sub commit_png($$$$) {
134 my ($name, $data, $T) = @_; 227 my ($stem, $name, $data, $T) = @_;
135 228
229 $FACEINFO{$name}{"stem"} = substr $stem, 1 + length $PATH;
136 $FACEINFO{$name}{"data$T"} = $data; 230 $FACEINFO{$name}{"data$T"} = $data;
137 } 231 }
138 232
139 sub process_png { 233 sub process_png {
140 while (@c_png) { 234 while (@c_png) {
… …
143 my $png; 237 my $png;
144 aio_lstat $path; 238 aio_lstat $path;
145 my ($size, $mtime) = (stat _)[7,9]; 239 my ($size, $mtime) = (stat _)[7,9];
146 240
147 if (0 > aio_load $path, $png) { 241 if (0 > aio_load $path, $png) {
148 warn "$path: $!, skipping.\n"; 242 warn "ERROR: $path: $!, skipping.\n";
149 next; 243 next;
150 } 244 }
151 245
152 my $stem = $path; 246 my $stem = $path;
153 my $T; 247 my $T;
… …
155 if ($stem =~ s/\.32x32\.png~?$//) { 249 if ($stem =~ s/\.32x32\.png~?$//) {
156 $T = 32; 250 $T = 32;
157 } elsif ($stem =~ s/\.64x64\.png~?$//) { 251 } elsif ($stem =~ s/\.64x64\.png~?$//) {
158 $T = 64; 252 $T = 64;
159 } else { 253 } else {
160 warn "$path: weird filename, skipping.\n"; 254 warn "ERROR: $path: weird filename, skipping.\n";
161 next; 255 next;
162 } 256 }
163 257
164 # quickly extract width and height of the (necessarily PNG) image 258 # quickly extract width and height of the (necessarily PNG) image
165 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) { 259 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
166 warn "$path: not a recognized png file, skipping.\n"; 260 warn "ERROR: $path: not a recognized png file, skipping.\n";
167 next; 261 next;
168 } 262 }
169 263
170 my ($w, $h) = unpack "NN", $1; 264 my ($w, $h) = unpack "NN", $1;
171 265
172 if ($w < $T || $h < $T) { 266 if ($w < $T || $h < $T) {
173 warn "$path: too small ($w $h), skipping.\n"; 267 warn "ERROR: $path: too small ($w $h), skipping.\n";
174 next; 268 next;
175 } 269 }
176 270
177 if ($w % $T || $h % $T) { 271 if ($w % $T || $h % $T) {
178 warn "$path: weird png size ($w $h), skipping.\n"; 272 warn "ERROR: $path: weird png size ($w $h), skipping.\n";
179 next; 273 next;
180 } 274 }
181 275
182 (my $base = $stem) =~ s/^.*\///; 276 (my $base = $stem) =~ s/^.*\///;
183 277
… …
192 unless ($path =~ /~$/) { 286 unless ($path =~ /~$/) {
193 # possibly enlarge 287 # possibly enlarge
194 if (0 > aio_stat "$stem.64x64.png") { 288 if (0 > aio_stat "$stem.64x64.png") {
195 my $other = "$stem.64x64.png~"; 289 my $other = "$stem.64x64.png~";
196 290
197 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 291 make_file $path, $other, sub {
198 fork_sub { 292 fork_exec {
199 my $CROP; 293 my $CROP;
200 my $SRC = "png:\Q$path\E"; 294 my $SRC = "png:\Q$path\E";
201 295
202 my $is_floor = $arc->{is_floor}; 296 my $is_floor = $arc->{is_floor};
203 my $is_wall = 0; 297 my $is_wall = 0;
… …
257 351
258 system "convert -depth 8 $SRC rgba:-" 352 system "convert -depth 8 $SRC rgba:-"
259 . "| $exec_prefix/bin/cfhq2xa $w $h 0" 353 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
260 . "| 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~"
261 and die "convert/cfhq2xa pipeline error: status $? ($!)"; 355 and die "convert/cfhq2xa pipeline error: status $? ($!)";
262 system $OPTIPNG, "-i0", "-q", "$other~"; 356 optipng "$other~";
263 die "$other~ has zero size, aborting." unless -s "$other~";
264 rename "$other~", $other; 357 rename "$other~", $other;
265 }; 358 };
266 } 359 };
267 360
268 push @c_png, [$other, !$CACHE]; 361 push @c_png, [$other, !$CACHE];
269 } 362 }
270 363
271 # possibly scale down 364 # possibly scale down
272 if (0 > aio_stat "$stem.32x32.png") { 365 if (0 > aio_stat "$stem.32x32.png") {
273 my $other = "$stem.32x32.png~"; 366 my $other = "$stem.32x32.png~";
274 367
275 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 368 make_file $path, $other, sub {
276 fork_sub { 369 fork_exec {
277 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~";
278 system $OPTIPNG, "-i0", "-q", "$other~"; 371 optipng "$other~";
279 372
280 # reduce smoothfaces >10000 bytes 373 # reduce smoothfaces >10000 bytes
281 # obsolete, no longer required 374 # obsolete, no longer required
282 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) { 375 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
283 my $ncolor = 256; 376 my $ncolor = 256;
284 while () { 377 while () {
285 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E"; 378 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
286 system $OPTIPNG, "-i0", "-q", "$other~~"; 379 optipng "$other~~";
287 last if 10000 > -s "$other~~"; 380 last if 10000 > -s "$other~~";
288 $ncolor = int $ncolor * 0.9; 381 $ncolor = int $ncolor * 0.9;
289 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes"; 382 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
290 } 383 }
291 384
… …
296 } 389 }
297 390
298 die "$other~ has zero size, aborting." unless -s "$other~"; 391 die "$other~ has zero size, aborting." unless -s "$other~";
299 rename "$other~", $other; 392 rename "$other~", $other;
300 }; 393 };
301 } 394 };
302 395
303 #warn "scaled down $path to $other\n";#d# 396 #warn "scaled down $path to $other\n";#d#
304 push @c_png, [$other, !$CACHE]; 397 push @c_png, [$other, !$CACHE];
305 } 398 }
306 } 399 }
307 400
308 (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 }
309 452
310 # split all bigfaces, but avoid smoothfaces (*_S) 453 # split all bigfaces, but avoid smoothfaces (*_S)
311 if (($w > $T || $h > $T) && $face !~ /_S\./) { 454 if (($w > $T || $h > $T) && $face !~ /_S\./) {
312 # split 455 # split
313 my @tile; 456 my @tile;
… …
318 push @tile, [$x, $y, $file, (stat _)[9]]; 461 push @tile, [$x, $y, $file, (stat _)[9]];
319 } 462 }
320 } 463 }
321 464
322 my $mtime = (lstat $path)[9]; 465 my $mtime = (lstat $path)[9];
323 my @todo = grep { $_->[3] <= $mtime } @tile; 466 my @todo = grep { $_->[3] < $mtime } @tile;
324 if (@todo) { 467 if (@todo) {
325 fork_sub { 468 fork_exec {
326 open my $convert, "|-", $CONVERT, 469 open my $convert, "|-", $CONVERT,
327 "png:-", 470 "png:-",
328 (map { 471 (map {
329 ( 472 (
330 "(", 473 "(",
… …
343 print $convert $png; 486 print $convert $png;
344 close $convert; 487 close $convert;
345 488
346 # pass 2, optimise, and rename 489 # pass 2, optimise, and rename
347 for (@todo) { 490 for (@todo) {
348 system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~"; 491 optipng "$_->[2]~";
349 die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
350 rename "$_->[2]~", $_->[2]; 492 rename "$_->[2]~", $_->[2];
351 } 493 }
352 }; 494 };
353 } 495 }
354 496
… …
358 500
359 if (0 > aio_load $file, $tile) { 501 if (0 > aio_load $file, $tile) {
360 die "$path: unable to read tile +$x+$y, aborting.\n"; 502 die "$path: unable to read tile +$x+$y, aborting.\n";
361 } 503 }
362 IO::AIO::aio_unlink $file unless $CACHE; 504 IO::AIO::aio_unlink $file unless $CACHE;
363 commit_png $x|$y ? "$face+$x+$y" : $face, $tile, $T; 505 commit_png $stem, $x|$y ? "$face+$x+$y" : $face, $tile, $T;
364 } 506 }
365 } else { 507 } else {
366 # use as-is (either small, use smooth) 508 # use as-is (either small, use smooth)
367 commit_png $face, $png, $T; 509 commit_png $stem, $face, $png, $T;
368 } 510 }
369 511
370 aio_unlink $path if $delete; 512 IO::AIO::aio_unlink $path if $delete;
513 }
514 }
515
516 sub process_faceinfo {
517 my ($dir, $file) = @_;
518 my $path = "$dir/$file";
519
520 my $data;
521 if (0 > aio_load $path, $data) {
522 warn "ERROR: $path: $!, skipping.\n";
523 return;
524 }
525
526 for (split /\n/, $data) {
527 chomp;
528 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
529 # bg not used except for text clients
530
531 utf8::decode $glyph;
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
536
537 (my $fgi = $COLOR{$fg})
538 // warn "ERROR: $path: $face specifies unknown foreground colour '$fg'.\n";
539 (my $bgi = $COLOR{$bg})
540 // warn "ERROR: $path: $face specifies unknown background colour '$bg'.\n";
541
542 my $fi = $FACEINFO{$face} ||= { };
543 $fi->{visibility} = $visibility * 1;
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 $_;
552 $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
553 }
371 } 554 }
372 } 555 }
373 556
374 sub process_arc { 557 sub process_arc {
375 while (my $job = $c_arc->get) { 558 while (my ($dir, $file) = @{ $c_arc->get }) {
376 my ($dir, $file) = @$job;
377
378 my $arc; 559 my $arc;
379 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/ 560 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
380 561
381 my $arc = read_arch "$dir/$file"; 562 my $arc = read_arch "$dir/$file";
382 for my $o (values %$arc) { 563 for my $o (values %$arc) {
383 push @ARC, $o; 564 push @ARC, $o;
384 for (my $m = $o; $m; $m = $m->{more}) { 565 for (my $m = $o; $m; $m = $m->{more}) {
385 $ARC{$m->{_name}} = $m; 566 $ARC{$m->{_name}} = $m;
386 } 567 }
387 568
388 $o->{editor_folder} = $dir; 569 $o->{editor_folder} ||= "\x00$dir"; # horrible kludge
389
390 my $visibility = delete $o->{visibility};
391 my $magicmap = delete $o->{magicmap};
392 570
393 # find upper left corner :/ 571 # find upper left corner :/
394 # omg, this is sooo broken 572 # omg, this is sooo broken
395 my ($dx, $dy); 573 my ($dx, $dy);
396 for (my $o = $o; $o; $o = $o->{more}) { 574 for (my $o = $o; $o; $o = $o->{more}) {
… …
403 my $y = $o->{y} - $dy; 581 my $y = $o->{y} - $dy;
404 582
405 my $ext = $x|$y ? "+$x+$y" : ""; 583 my $ext = $x|$y ? "+$x+$y" : "";
406 584
407 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face}; 585 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face};
408
409 $visibility = delete $o->{visibility} if exists $o->{visibility};
410 $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
411 586
412 my $anim = delete $o->{anim}; 587 my $anim = delete $o->{anim};
413 588
414 if ($anim) { 589 if ($anim) {
415 # possibly add $ext to the animation name to avoid 590 # possibly add $ext to the animation name to avoid
… …
439 next if /^facings\s/; 614 next if /^facings\s/;
440 615
441 my $face = $_; 616 my $face = $_;
442 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates 617 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
443 618
444 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
445 $info->{arc} = $o; 625 $FACEINFO{$face}{arc} = $o;
446 626
447 next if $face =~ /^blank.x11$|^empty.x11$/; 627 next if $face =~ /^blank.x11$|^empty.x11$/;
448
449 $info->{visibility} = $visibility if defined $visibility;
450 $info->{magicmap} = $magicmap if defined $magicmap;
451 } 628 }
452 629
453 if (my $smooth = delete $o->{smoothface}) { 630 if (my $smooth = delete $o->{smoothface}) {
454 my %kv = split /\s+/, $smooth; 631 my %kv = split /\s+/, $smooth;
455 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 632 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
… …
464 } 641 }
465 } 642 }
466 } 643 }
467 644
468 sub process_trs { 645 sub process_trs {
469 while (my $job = $c_trs->get) {
470 my ($dir, $file) = @$job; 646 my ($dir, $file) = @_;
471 my $path = "$dir/$file"; 647 my $path = "$dir/$file";
472 648
473 my $trs; 649 my $trs;
474 if (0 > aio_load $path, $trs) { 650 if (0 > aio_load $path, $trs) {
475 warn "$path: $!, skipping.\n"; 651 warn "ERROR: $path: $!, skipping.\n";
476 next; 652 return;
477 } 653 }
478 654
479 $TRS .= $trs; 655 $TRS .= $trs;
480 }
481 } 656 }
482 657
483 my %FILECACHE; 658 my %FILECACHE;
484 659
485 sub load_cached($;$) { 660 sub load_cached($;$) {
486 unless (exists $FILECACHE{$_[0]}) { 661 unless (exists $FILECACHE{$_[0]}) {
487 my $data; 662 my $data;
488 if (0 < aio_load $_[0], $data) { 663 if (0 < aio_load $_[0], $data) {
489 if ($_[1]) { 664 if ($_[1]) {
490 $data = eval { $_[1]->($data) }; 665 $data = eval { $_[1]->($data) };
491 warn "$_[0]: $@" if $@; 666 warn "ERROR: $_[0]: $@" if $@;
492 } 667 }
493 } 668 }
494 669
495 $FILECACHE{$_[0]} = $data; 670 $FILECACHE{$_[0]} = $data;
496 } 671 }
497 672
498 $FILECACHE{$_[0]} 673 $FILECACHE{$_[0]}
499 } 674 }
500 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 }
742 }
743
501 sub process_res { 744 sub process_res {
502 while (my $job = $c_res->get) {
503 my ($dir, $file, $type) = @$job; 745 my ($dir, $file, $type) = @_;
504 746
505 my $data;
506 aio_load "$dir/$file", $data; 747 0 <= aio_load "$dir/$file", my $data
748 or die "$dir/$file: $!";
507 749
508 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) };
509 751
510 utf8::decode $dir; 752 utf8::decode $dir;
511 utf8::decode $file; 753 utf8::decode $file;
512 754
513 # a meta file for resources is now mandatory 755 # a meta file for resources is now mandatory
514 unless (exists $meta->{$file}) { 756 unless (exists $meta->{$file}) {
515 warn "skipping $dir/$file\n" if $VERBOSE >= 3; 757 warn "skipping $dir/$file\n" if $VERBOSE >= 3;
516 next; 758 return;
517 } 759 }
518 760
519 $meta = { 761 $meta = {
520 %{ $meta->{"" } || {} }, 762 %{ $meta->{"" } || {} },
521 %{ $meta->{$file} || {} }, 763 %{ $meta->{$file} || {} },
522 }; 764 };
523 765
524 if ($meta->{license} =~ s/^#//) { 766 if (exists $meta->{license} && $meta->{license} =~ s/^#//) { # exists == avoid autovivification
525 $meta->{license} = ({ 767 $meta->{license} = ({
526 "pd" => "Public Domain", 768 "pd" => "Public Domain",
527 "gpl" => "GNU General Public License, version 3.0 or any later", 769 "gpl" => "GNU General Public License, version 3.0 or any later",
528 "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/",
771 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
529 "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/",
530 "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/",
531 })->{$meta->{license}} 774 })->{$meta->{license}}
532 || warn "$dir/$file: license tag '$meta->{license}' not found."; 775 || warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
533 } 776 }
534 777
778 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
779 ($meta->{author} = $1) =~ s/_/ /g;
780 }
781
535 $file =~ s/\.res$//; 782 $file =~ s/\.res$//;
536 $file =~ s/\.(ogg|wav|jpg|png)$//; 783 $file =~ s/\.(ogg|wav|jpg|png)$//;
537 784
538 substr $dir, 0, 1 + length $PATH, ""; 785 if ($file =~ s/\.plt$//) {
539 786 $data = process_plt "$dir/$file", $data;
540 if (my $filter = $meta->{cfutil_filter}) { 787 } elsif (my $filter = delete $meta->{cfutil_filter}) {
541 if ($filter eq "yaml2json") { 788 if ($filter eq "yaml2json") {
542 $data = JSON::XS::encode_json YAML::XS::Load $data; 789 $data = JSON::XS::encode_json YAML::XS::Load $data;
543 } elsif ($filter eq "json2json") { 790 } elsif ($filter eq "json2json") {
544 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); 791 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
545 } elsif ($filter eq "perl2json") { 792 } elsif ($filter eq "perl2json") {
546 $data = eval $data; die if $@; 793 $data = eval $data; die if $@;
547 $data = JSON::XS::encode_json $data; 794 $data = JSON::XS::encode_json $data;
548 } else { 795 } else {
549 warn "$dir/$file: unknown filter $filter, skipping\n"; 796 warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
550 } 797 }
551 } 798 }
552 799
800 substr $dir, 0, 1 + length $PATH, "";
801
553 $RESOURCE{"$dir/$file"} = { 802 $RESOURCE{"$dir/$file"} = {
554 type => (exists $meta->{type} ? delete $meta->{type} : $type), 803 type => (exists $meta->{type} ? delete $meta->{type} : $type),
555 data => $data, 804 data => $data,
556 %$meta ? (meta => $meta) : (), 805 %$meta ? (meta => $meta) : (),
557 }; 806 };
807 }
808
809 sub process_any {
810 while (my ($func, @args) = @{ $c_any->get }) {
811 $func->(@args);
558 } 812 }
559 } 813 }
560 814
561 sub find_files; 815 sub find_files;
562 sub find_files { 816 sub find_files {
563 my ($path) = @_; 817 my ($path) = @_;
564 818
819 my $grp = IO::AIO::aio_group;
820
821 my $scandir; $scandir = sub {
822 my ($path) = @_;
823
565 IO::AIO::aioreq_pri 4; 824 IO::AIO::aioreq_pri 4;
566 IO::AIO::aio_scandir $path, 4, sub { 825 add $grp IO::AIO::aio_scandir $path, 4, sub {
567 my ($dirs, $nondirs) = @_; 826 my ($dirs, $nondirs) = @_;
568 827
569 find_files "$path/$_" 828 $scandir->("$path/$_")
570 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs; 829 for grep $_ !~ /^(?:CVS|dev|\..*)$/, @$dirs;
571 830
572 my $dir = $path; 831 my $dir = $path;
573 substr $dir, 0, 1 + length $PATH, ""; 832 substr $dir, 0, 1 + length $PATH, "";
574 833
575 for my $file (@$nondirs) { 834 for my $file (@$nondirs) {
576 if ($dir =~ /^music(?:\/|$)/) { 835 if ($dir =~ /^music(?:\/|$)/) {
577 $c_res->put ([$path, $file, 3]) # FT_MUSIC 836 $c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
578 if $file =~ /\.(ogg)$/; 837 if $file =~ /\.(ogg)$/;
579 838
580 } elsif ($dir =~ /^sound(?:\/|$)/) { 839 } elsif ($dir =~ /^sound(?:\/|$)/) {
581 $c_res->put ([$path, $file, 5]) # FT_SOUND 840 $c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
582 if $file =~ /\.(wav|ogg)$/; 841 if $file =~ /\.(wav|ogg)$/;
583 842
584 } elsif ($dir =~ /^res(?:\/|$)/) { 843 } elsif ($dir =~ /^res(?:\/|$)/) {
585 if ($file =~ /\.(jpg|png)$/) { 844 if ($file =~ /\.(jpg|png)$/) {
586 $c_res->put ([$path, $file, 0]) # FT_FACE 845 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
587 } elsif ($file =~ /\.(res)$/) { 846 } elsif ($file =~ /\.(res)$/) {
847 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
848 } else {
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
850 }
851
852 } elsif ($file =~ /\.png$/) {
853 $PNG{$file} = $path;
854
855 } elsif ($file =~ /\.faceinfo$/) {
856 $c_any->put ([\&process_faceinfo, $path, $file]);
857
858 } elsif ($file =~ /\.trs$/) {
859 $c_any->put ([\&process_trs, $path, $file]);
860
861 } elsif ($file =~ /\.arc$/) {
588 $c_res->put ([$path, $file, 6]) # FT_RSRC 862 $c_arc->put ([$path, $file]);
863
589 } else { 864 } else {
590 $c_res->put ([$path, $file, undef]); 865 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
591 } 866 }
592
593 } elsif ($file =~ /\.png$/) {
594 push @c_png, ["$path/$file", 0];
595
596 } elsif ($file =~ /\.trs$/) {
597 $c_trs->put ([$path, $file]);
598
599 } elsif ($file =~ /\.arc$/) {
600 $c_arc->put ([$path, $file]);
601
602 } else { 867 }
603 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
604 }
605 } 868 };
606 }; 869 };
870
871 $scandir->($path);
872 aio_wait $grp;
607 } 873 }
608 874
609 sub generate_plurals { 875 sub generate_plurals {
610# use Lingua::EN::Inflect (); 876# use Lingua::EN::Inflect ();
611# Lingua::EN::Inflect::classical; 877# Lingua::EN::Inflect::classical;
612# Lingua::EN::Inflect::def_noun 'talisman' => 'talismans'; 878# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
613# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack 879# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
614# 880#
615# for my $a (@ARC) { 881# for my $a (@ARC) {
616# my $name = $a->{name} || $a->{_name}; 882# my $name = $a->{name} || $a->{_name};
617# 883#
618# next unless $a->{name_pl}; 884# next unless $a->{name_pl};
619# 885# next if $a->{invisible};
886# next if $a->{is_floor};
887# next if $a->{no_pick};
620# 888#
621# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name; 889# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
622# my $pl = $test =~ /^(?:eq|p:.)$/ 890# my $pl = $test =~ /^(?:eq|p:.)$/
623# ? $name 891# ? $name
624# : Lingua::EN::Inflect::PL $name; 892# : Lingua::EN::Inflect::PL $name;
625# die "$test $pl" if $pl =~ /bootss/;#d#
626# 893#
627# if ($pl ne $a->{name_pl}) { 894# if ($pl ne $a->{name_pl}) {
628# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n"; 895# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
629# } 896# }
630# } 897# }
… …
644 "Unless you run verbosely, all following warning\n", 911 "Unless you run verbosely, all following warning\n",
645 "or error messages indicate serious problems.\n", 912 "or error messages indicate serious problems.\n",
646 "\n"; 913 "\n";
647 914
648 if (!-d "$path/treasures") { 915 if (!-d "$path/treasures") {
649 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";
650 exit 1 unless $FORCE; 917 exit 1 unless $FORCE;
651 } 918 }
652 919
653 print "scanning files...\n" if $VERBOSE; 920 print "starting file scan, arc, any processing...\n" if $VERBOSE;
921
922 my @a_arc = map +(async \&process_arc), 1..2;
923 my @a_any = map +(async \&process_any), 1..4;
654 924
655 find_files $path; 925 find_files $path;
656 926
657 my @a_arc = map +(async \&process_arc), 1..2;
658 my @a_res = map +(async \&process_res), 1..2;
659 my @a_trs = map +(async \&process_trs), 1..2;
660
661 IO::AIO::flush;
662
663 $c_res->shutdown;
664 $c_arc->shutdown; 927 $c_arc->shutdown;
665 $c_trs->shutdown; 928 $c_any->shutdown;
666
667 print "start file scan, arc, res processing...\n" if $VERBOSE;
668 929
669 $_->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;
670 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
671 print "end arc, start png processing...\n" if $VERBOSE; 956 print "starting png processing...\n" if $VERBOSE;
672 957
673 # eight png crunchers work fine for my 4x smp machine 958 # eight png crunchers work fine for my 4x smp machine
674 my @a_png = map +(async \&process_png), 1..8; 959 my @a_png = map +(async \&process_png), 1..8;
675 960
676 $_->join for (@a_trs, @a_res, @a_png); 961 $_->join for @a_any;
962 print "finished any processing...\n" if $VERBOSE;
963
964 $_->join for @a_png;
965 print "finished png processing...\n" if $VERBOSE;
677 966
678 print "scanning done, processing results...\n" if $VERBOSE; 967 print "scanning done, processing results...\n" if $VERBOSE;
679 { 968 {
680 # remove path prefix from editor_folder 969 # remove path prefix from editor_folder
970 $_->{editor_folder} =~ /^\x00/
681 substr $_->{editor_folder}, 0, 1 + length $path, "" 971 and substr $_->{editor_folder}, 0, 2 + length $path, ""
682 for values %ARC; 972 for values %ARC;
683 973
684 print "resolving inheritance tree...\n" if $VERBOSE; 974 print "resolving inheritance tree...\n" if $VERBOSE;
685 # resolve inherit 975 # resolve inherit
686 while () { 976 while () {
687 my $progress; 977 my $progress;
688 my $loop; 978 my $loop;
689 979
690 for my $o (values %ARC) { 980 for my $o (values %ARC) {
691 if (my $other = $o->{inherit}) { 981 for my $other (split /,/, $o->{inherit}) {
692 if (my $s = $ARC{$other}) { 982 if (my $s = $ARC{$other}) {
693 if ($s->{inherit}) { 983 if ($s->{inherit}) {
694 $loop = $s; 984 $loop = $s;
695 } else { 985 } else {
696 delete $o->{inherit}; 986 delete $o->{inherit};
… …
698 delete @s{qw(_name more name name_pl)}; 988 delete @s{qw(_name more name name_pl)};
699 %$o = ( %s, %$o ); 989 %$o = ( %s, %$o );
700 ++$progress; 990 ++$progress;
701 } 991 }
702 } else { 992 } else {
703 warn "'$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";
704 delete $ARC{$o->{_name}}; 994 delete $ARC{$o->{_name}};
705 } 995 }
706 } 996 }
707 } 997 }
708 998
… …
715 } 1005 }
716 1006
717 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit 1007 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
718 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC; 1008 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC;
719 1009
1010 # fix up archetypes without names, where the archanme doesn't work at all
1011 for (@ARC) {
1012 if (!exists $_->{name} and $_->{_name} =~ /_/) {
1013 for ($_->{name} = $_->{_name}) {
1014 s/(?:_\d+)+$//;
1015 s/_[nesw]+$//;
1016 y/_/ /;
1017 }
1018 }
1019 }
1020
720 print "generating plurals...\n" if $VERBOSE; 1021 #print "generating plurals...\n" if $VERBOSE;
721 generate_plurals; 1022 #generate_plurals;
722 1023
723 print "writing archetypes...\n" if $VERBOSE; 1024 printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
724 open my $fh, ">:utf8", "$DATADIR/archetypes~" 1025 open my $fh, ">:utf8", "$DATADIR/archetypes~"
725 or die "$DATADIR/archetypes~: $!"; 1026 or die "$DATADIR/archetypes~: $!";
726 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];
727 } 1028 }
728 1029
729 { 1030 {
730 print "writing treasures...\n" if $VERBOSE; 1031 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
731 open my $fh, ">:utf8", "$DATADIR/treasures~" 1032 open my $fh, ">:utf8", "$DATADIR/treasures~"
732 or die "$DATADIR/treasures~: $!"; 1033 or die "$DATADIR/treasures~: $!";
733 print $fh $TRS; 1034 print $fh $TRS;
734 } 1035 }
735 1036
736 { 1037 {
737 print "processing facedata...\n" if $VERBOSE; 1038 print "processing facedata...\n" if $VERBOSE;
738 while (my ($k, $v) = each %FACEINFO) { 1039 while (my ($k, $v) = each %FACEINFO) {
739 length $v->{data32} or warn "$k: face 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";
740 length $v->{data64} or warn "$k: face 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";
741 1042
1043 make_hash $k, $v->{data32}, $v->{hash32};
1044 make_hash $k, $v->{data64}, $v->{hash64};
1045
742 #length $v->{data32} <= 10000 or warn "$k: 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";
743 #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n"; 1047 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
744 1048
745 if (my $magicmap = $v->{magicmap}) { 1049 $v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
746 $magicmap =~ y/A-Z_\-/a-z/d; 1050 $v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
747 $v->{magicmap} = $COLOR{$magicmap}; 1051 $v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
1052
1053 delete @$v{qw(arc stem derive)}; # not used by the server
1054 }
1055
1056 print "processing resources...\n" if $VERBOSE;
1057 my $enc = JSON::XS->new->utf8->canonical->relaxed;
1058 while (my ($k, $v) = each %RESOURCE) {
1059
1060 if ($v->{meta} && $v->{meta}{datadir}) {
1061 delete $RESOURCE{$k};
1062
1063 $k =~ s/^res\/// or die "$k: datadir files must be in res/";
1064
1065 printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
1066 open my $fh, ">:raw", "$DATADIR/$k~"
1067 or die "$DATADIR/$k~: $!";
1068 syswrite $fh, $v->{data};
1069 push @COMMIT, $k;
1070
1071 } else {
1072 if ($v->{type} & 1) {
1073 # prepend meta info
1074
1075 my $meta = $enc->encode ({
1076 name => $k,
1077 %{ $v->{meta} || {} },
1078 });
1079
1080 $v->{data} = pack "(w/a*)*", $meta, $v->{data};
748 } 1081 }
749 1082
750 delete $v->{arc}; 1083 make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
751 } 1084 }
1085 }
752 1086
753 print "writing facedata...\n" if $VERBOSE; 1087 printf "writing facedata (%d faces, %d anims, %d resources)...\n",
1088 scalar keys %FACEINFO,
1089 scalar keys %ANIMINFO,
1090 scalar keys %RESOURCE
1091 if $VERBOSE;
1092
754 open my $fh, ">:perlio", "$DATADIR/facedata~" 1093 open my $fh, ">:perlio", "$DATADIR/facedata~"
755 or die "$DATADIR/facedata~: $!"; 1094 or die "$DATADIR/facedata~: $!";
756 1095
757 print $fh freeze { 1096 print $fh nfreeze {
758 version => 2, 1097 version => 2,
759 faceinfo => \%FACEINFO, 1098 faceinfo => \%FACEINFO,
760 animinfo => \%ANIMINFO, 1099 animinfo => \%ANIMINFO,
761 resource => \%RESOURCE, 1100 resource => \%RESOURCE,
762 }; 1101 };
763 } 1102 }
764 1103
765 print "committing files...\n" if $VERBOSE; 1104 print "committing files...\n" if $VERBOSE;
766 1105
767 for (qw(archetypes facedata treasures)) { 1106 for (qw(archetypes facedata treasures), @COMMIT) {
768 chmod 0644, "$DATADIR/$_~"; 1107 chmod 0644, "$DATADIR/$_~";
769 rename "$DATADIR/$_~", "$DATADIR/$_" 1108 rename "$DATADIR/$_~", "$DATADIR/$_"
770 or die "$DATADIR/$_: $!"; 1109 or die "$DATADIR/$_: $!";
771 } 1110 }
772 1111

Diff Legend

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