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.27 by root, Wed Apr 18 07:59:03 2007 UTC vs.
Revision 1.125 by root, Mon Nov 19 00:40:55 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@";
11my $IDENTIFY = "@IDENTIFY@"; 33my $IDENTIFY = "@IDENTIFY@";
12my $OPTIPNG = "@OPTIPNG@"; 34my $OPTIPNG = "@OPTIPNG@";
13my $RSYNC = "@RSYNC@"; 35my $RSYNC = "@RSYNC@";
36my $PNGNQ = "@PNGNQ@";
14 37
15use Getopt::Long; 38use Getopt::Long;
16use Coro::Event; 39use File::Temp;
40use POSIX ();
41use Carp;
42
43use YAML::XS ();
44use Digest::MD5 ();
45use Storable ();
46use JSON::XS ();
47use IO::AIO ();
48use Compress::LZF ();
49
17use AnyEvent; 50use AnyEvent;
18use IO::AIO (); 51use Coro 5.12;
19use File::Temp;
20use Crossfire;
21use Coro; 52use Coro::EV;
22use Coro::AIO; 53use Coro::AIO;
23use POSIX (); 54use Coro::Util;
24use Digest::MD5; 55use Coro::Channel;
56use Coro::AnyEvent;
25use Coro::Storable; $Storable::canonical = 1; 57use Coro::Storable; $Storable::canonical = 1;
58
59use Deliantra;
60
61$SIG{QUIT} = sub { Carp::cluck "QUIT" };
26 62
27sub usage { 63sub usage {
28 warn <<EOF; 64 warn <<EOF;
29Usage: cfutil [-v] [-q] [--force] [--cache] 65Usage: cfutil [-v] [-q] [--force] [--cache]
30 [--install-arch path] 66 [--install-arch path]
… …
41my $VERBOSE = 1; 77my $VERBOSE = 1;
42my $CACHE = 0; 78my $CACHE = 0;
43my $FORCE; 79my $FORCE;
44my $TMPDIR = "/tmp/cfutil$$~"; 80my $TMPDIR = "/tmp/cfutil$$~";
45my $TMPFILE = "aaaa0"; 81my $TMPFILE = "aaaa0";
82my @COMMIT;
83
84our %COLOR = (
85 # original cf colours
86 black => 0,
87 white => 1,
88 navy => 2, # "dark blue"
89 red => 3,
90 orange => 4,
91 blue => 5, # "light blue"
92 darkorange => 6,
93 green => 7,
94 lightgreen => 8,
95 grey => 9,
96 brown => 10, # "yellow"
97 gold => 11, # "light yellow"
98 tan => 12, # yellowish gray
99
100 # new for deliantra
101 none => 13,
102
103 # compatibility to existing archetypes
104 lightblue => 5,
105 gray => 9,
106 yellow => 11,
107 khaki => 12,
108);
46 109
47END { system "rm", "-rf", $TMPDIR } 110END { system "rm", "-rf", $TMPDIR }
48 111
49Event->signal (signal => "INT", cb => sub { exit 1 }); 112my $s_INT = AE::signal INT => sub { exit 1 };
50Event->signal (signal => "TERM", cb => sub { exit 1 }); 113my $s_TERM = AE::signal TERM => sub { exit 1 };
114
115our %hash;
116
117# here we could try to avoid collisions and reduce chksum size further
118sub make_hash($\$\$;$) {
119 my ($id, $dataref, $hashref, $clen) = @_;
120
121 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 5;
122
123 if (exists $hash{$hash}) {
124 # hash collision, but some files are simply identical
125 if (${$hash{$hash}[1]} ne $$dataref) {
126 warn "ERROR: hash collision $hash{$hash}[0] vs. $id (increase the default \$clen in make_hash?)\n";
127 exit 1;
128 } else {
129 print "$hash{$hash}[0] and $id are identical (which is fine).\n" if $VERBOSE >= 3;
130 }
131 }
132 $hash{$hash} = [$id, $dataref, $hashref];
133
134 $$hashref = $hash;
135}
136
137sub optipng($) {
138 system $OPTIPNG, "-o5", "-i0", "-q", $_[0];
139 die "$_[0] has zero size, aborting." unless -s $_[0];
140}
51 141
52mkdir $TMPDIR, 0700 142mkdir $TMPDIR, 0700
53 or die "$TMPDIR: $!"; 143 or die "$TMPDIR: $!";
54 144
55sub fork_sub(&) { 145sub fork_exec(&) {
56 my ($cb) = @_; 146 my ($cb) = @_;
57 147
58 if (my $pid = fork) { 148 if (my $pid = fork) {
59 my $current = $Coro::current; 149 my $current = $Coro::current;
60 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); 150 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
… …
65 warn $@; 155 warn $@;
66 POSIX::_exit 1; 156 POSIX::_exit 1;
67 } 157 }
68} 158}
69 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
70sub inst_maps($) { 189sub inst_maps($) {
71 my (undef, $path) = @_; 190 my (undef, $path) = @_;
72 191
73 print "installing '$path' to '$DATADIR/maps'\n"; 192 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
74 193
75 if (!-f "$path/regions") { 194 if (!-f "$path/regions") {
76 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";
77 exit 1 unless $FORCE; 196 exit 1 unless $FORCE;
78 } 197 }
79 198
80 system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded" 199 system $RSYNC, "-av", "--chmod=u=rwX,go=rX",
200 "$path/.", "$DATADIR/maps/.",
201 "--exclude", "CVS", "--exclude", "/world-precomposed",
202 "--delete", "--delete-excluded"
81 and die "map installation failed.\n"; 203 and die "map installation failed.\n";
82 204
83 print "maps installed successfully.\n"; 205 print "maps installed successfully.\n";
84} 206}
85 207
86{ 208{
87 our %ANIMINFO; 209 our %ANIMINFO;
88 our %FACEINFO; 210 our %FACEINFO;
211 our %RESOURCE;
212 our @ARC;
89 our %ARC; 213 our %ARC;
90 our $TRS; 214 our $TRS;
215 our %PNG;
91 our $NFILE; 216 our $NFILE;
217 our $PATH;
92 218
93 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 219 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
94 220
95 our (@png, @trs, @arc); # files we are interested in 221 our $c_arc = new Coro::Channel;
222 our $c_any = new Coro::Channel;
96 223
224 our @c_png;
225
226 # texture catalog size, in 64x64 tiles
227 sub TC_W() { 1024 / 64 }
228 sub TC_H() { 1024 / 64 }
229
230 our @TC = ([]); # texture catalogs
231
97 sub commit_png($$$) { 232 sub commit_png($$$$$$) {
98 my ($name, $data, $T) = @_; 233 my ($stem, $name, $data, $T, $w, $h) = @_;
99 234
235 $FACEINFO{$name}{stem} = substr $stem, 1 + length $PATH;
100 $FACEINFO{$name}{"data$T"} = $data; 236 $FACEINFO{$name}{"data$T"} = $data;
237 $FACEINFO{$name}{w} = $w;
238 $FACEINFO{$name}{h} = $h;
101 } 239 }
102 240
103 sub process_png { 241 sub process_png {
104 while (@png) { 242 while (@c_png) {
105 my ($path, $delete) = @{pop @png}; 243 my ($path, $delete) = @{pop @c_png};
106 244
107 my $png; 245 my $png;
108 aio_lstat $path; 246 aio_lstat $path;
109 my ($size, $mtime) = (stat _)[7,9]; 247 my ($size, $mtime) = (stat _)[7,9];
110 248
111 if (0 > aio_load $path, $png) { 249 if (0 > aio_load $path, $png) {
112 warn "$path: $!, skipping.\n"; 250 warn "ERROR: $path: $!, skipping.\n";
113 next; 251 next;
114 } 252 }
115 253
116 my $stem = $path; 254 my $stem = $path;
117 my $T; 255 my $T;
… …
119 if ($stem =~ s/\.32x32\.png~?$//) { 257 if ($stem =~ s/\.32x32\.png~?$//) {
120 $T = 32; 258 $T = 32;
121 } elsif ($stem =~ s/\.64x64\.png~?$//) { 259 } elsif ($stem =~ s/\.64x64\.png~?$//) {
122 $T = 64; 260 $T = 64;
123 } else { 261 } else {
124 warn "$path: weird filename, skipping.\n"; 262 warn "ERROR: $path: weird filename, skipping.\n";
125 next; 263 next;
126 } 264 }
127 265
128 # quickly extract width and height of the (necessarily PNG) image 266 # quickly extract width and height of the (necessarily PNG) image
129 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) { 267 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
130 warn "$path: not a recognized png file, skipping.\n"; 268 warn "ERROR: $path: not a recognized png file, skipping.\n";
131 next; 269 next;
132 } 270 }
133 271
134 my ($w, $h) = unpack "NN", $1; 272 my ($w, $h) = unpack "NN", $1;
135 273
136 if ($w < $T || $h < $T) { 274 if ($w < $T || $h < $T) {
137 warn "$path: too small ($w $h), skipping.\n"; 275 warn "ERROR: $path: too small ($w $h), skipping.\n";
138 next; 276 next;
139 } 277 }
140 278
141 if ($w % $T || $h % $T) { 279 if ($w % $T || $h % $T) {
142 warn "$path: weird png size ($w $h), skipping.\n"; 280 warn "ERROR: $path: weird png size ($w $h), skipping.\n";
143 next; 281 next;
144 } 282 }
283
284 (my $base = $stem) =~ s/^.*\///;
285
286 my $fi = $FACEINFO{$base};
287 unless ($fi) {
288 #warn "$path: <$base> not referenced by any archetype, skipping.\n";
289 #next;
290 }
291
292 my $arc = $fi->{arc} || { };
145 293
146 unless ($path =~ /~$/) { 294 unless ($path =~ /~$/) {
147 # possibly enlarge 295 # possibly enlarge
148 if (0 > aio_stat "$stem.64x64.png") { 296 if (0 > aio_stat "$stem.64x64.png") {
149 my $other = "$stem.64x64.png~"; 297 my $other = "$stem.64x64.png~";
150 298
151 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 299 make_file $path, $other, sub {
152 my $wrap = 0; # for the time being
153 fork_sub { 300 fork_exec {
301 my $CROP;
302 my $SRC = "png:\Q$path\E";
303
304 my $is_floor = $arc->{is_floor};
305 my $is_wall = 0;
306
307 my ($wall_pfx, $wall_dir, $wall_sfx);
308
309 if (
310 !$is_floor
311 && !$arc->{alive}
312 && $arc->{move_block} eq "all"
313 && $path =~ /^(.*_)([0-9A-F])(\.x11.*\.png)$/
314 ) {
315 ($wall_pfx, $wall_dir, $wall_sfx) = ($1, hex $2, $3);
316
317 unless (grep { !-e sprintf "%s%X%s", $wall_pfx, $_, $wall_sfx } 0..15) {
318 $is_wall = 1;
319 }
320 }
321
322 if ($is_wall || $is_floor) {
323 # add a 4px border and add other images around it
324 $CROP = "-shave 8x8 +repage";
325
326 $w += 8;
327 $h += 8;
328
329 $SRC = "-size ${w}x${h} xc:transparent";
330 $SRC .= " png:\Q$path\E -geometry +4+4 -composite";
331
332 # 8 surrounding images
333 for (
334 # x y b r0 r1
335 [-1, -1, 0, 6],
336 [ 0, -1, 1, 10, 14],
337 [+1, -1, 0, 12],
338
339 [-1, 0, 8, 5, 7],
340 #
341 [+1, 0, 2, 5, 13],
342
343 [-1, +1, 0, 3],
344 [ 0, +1, 4, 10, 11],
345 [+1, +1, 0, 9],
346 ) {
347 my ($x, $y, $d, $r0, $r1) = @$_;
348
349 my $tile = $is_floor ? $path
350 : $is_wall ? sprintf "%s%X%s", $wall_pfx, ($wall_dir & $d) ? $r1 : $r0, $wall_sfx
351 : die;
352
353 $SRC .= sprintf " png:%s -geometry %+d%+d -composite",
354 "\Q$tile",
355 $x * ($w - 8) + 4,
356 $y * ($h - 8) + 4;
357 }
358 }
359
154 system "convert png:\Q$path\E -depth 8 rgba:-" 360 system "$CONVERT -depth 8 $SRC rgba:-"
155 . "| $exec_prefix/bin/cfhq2xa $w $h $wrap" 361 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
156 . "| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $QUANTIZE -quality 00 png32:\Q$other\E~" 362 . "| $CONVERT -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $CROP $QUANTIZE -quality 00 png32:\Q$other\E~"
157 and die "convert/hq2xa pipeline error: status $? ($!)"; 363 and die "convert/cfhq2xa pipeline error: status $? ($!)";
158 system $OPTIPNG, "-o5", "-i0", "-q", "$other~"; 364 optipng "$other~";
365 rename "$other~", $other;
366 };
367 };
368
369 push @c_png, [$other, !$CACHE];
370 }
371
372 # possibly scale down
373 if (0 > aio_stat "$stem.32x32.png") {
374 my $other = "$stem.32x32.png~";
375
376 make_file $path, $other, sub {
377 fork_exec {
378 system "$CONVERT png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
379 optipng "$other~";
380
381 # reduce smoothfaces >10000 bytes
382 # obsolete, no longer required
383 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
384 my $ncolor = 256;
385 while () {
386 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
387 optipng "$other~~";
388 last if 10000 > -s "$other~~";
389 $ncolor = int $ncolor * 0.9;
390 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
391 }
392
393 printf "reduced %s from %d to %d bytes using %d colours.\n",
394 $other, -s "$other~", -s "$other~~", $ncolor
395 if $VERBOSE >= 2;
396 rename "$other~~", "$other~";
397 }
398
159 die "$other~ has zero size, aborting." unless -s "$other~"; 399 die "$other~ has zero size, aborting." unless -s "$other~";
160 rename "$other~", $other; 400 rename "$other~", $other;
161 }; 401 };
162 } 402 };
163 403
404 #warn "scaled down $path to $other\n";#d#
164 push @png, [$other, !$CACHE]; 405 push @c_png, [$other, !$CACHE];
406 }
165 } 407 }
166 408
167 # possibly scale down 409 (my $face = $stem) =~ s/^.*\///;
168 if (0 > aio_stat "$stem.32x32.png") {
169 my $other = "$stem.32x32.png~";
170 410
171 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 411 for (@{ $fi->{derive} }) {
412 my ($dir, $type) = @$_;
413
414 my $geom = "${T}x${T}";
415 my $dpath = "$dir/$type:$face.$geom.png~";
416
417 if ($type eq "buildmaterial") {
418 my $ov = "$PATH/mapbuilding/buildmaterial.png";
419 make_file [$path, $ov], $dpath, sub {
172 fork_sub { 420 fork_exec {
173 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~"; 421 system "$CONVERT -size 64x64 xc:transparent \\( \Q$path\E -geometry 52x52+6+6 \\) -composite \Q$ov\E -composite -geometry $geom png:\Q$dpath\E~";
174 system $OPTIPNG, "-o5", "-i0", "-q", "$other~"; 422 optipng "$dpath~";
175 die "$other~ has zero size, aborting." unless -s "$other~";
176 rename "$other~", $other; 423 rename "$dpath~", $dpath;
177 }; 424 };
178 } 425 };
179 426 } elsif ($type eq "buildmaterial-box") {
180 #warn "scaled down $path to $other\n";#d# 427 my $ov = "$PATH/mapbuilding/buildmaterial-box.png";
181 push @png, [$other, !$CACHE]; 428 make_file [$path, $ov], $dpath, sub {
429 fork_exec {
430 system "$CONVERT \Q$ov\E "
431 . "\\( \Q$path\E -trim -geometry 34x31\\> "
432 . "-gravity center -background transparent -extent 37x34 +gravity "
433 . "-geometry +22+6 \\) -composite "
434 . "-geometry $geom png:\Q$dpath\E~";
435 optipng "$dpath~";
436 rename "$dpath~", $dpath;
437 };
182 } 438 };
439 } elsif ($type eq "buildmaterial-sbox") {
440 my $ov = "$PATH/mapbuilding/buildmaterial-sbox.png";
441 make_file [$path, $ov], $dpath, sub {
442 fork_exec {
443 system "$CONVERT \Q$ov\E "
444 . "\\( \Q$path\E -trim -geometry 16x24\\> "
445 . "-gravity center -background transparent -extent 18x26 +gravity "
446 . "-geometry +26+16 \\) -composite "
447 . "-geometry $geom png:\Q$dpath\E~";
448 optipng "$dpath~";
449 rename "$dpath~", $dpath;
450 };
451 };
452 } else {
453 warn "ERROR: facename $type:$face contains unsupported derivation type.\n";
183 } 454 }
184 455
185 (my $face = $stem) =~ s/^.*\///; 456 aio_load $dpath, my $png;
457 IO::AIO::aio_unlink $dpath unless $CACHE;
458 commit_png "$dir/$type:$face", "$type:$face", $png, $T, 1, 1;
459 }
186 460
187 # split all bigfaces, but avoid smoothfaces (*_S) 461 # split all bigfaces, but avoid smoothfaces (*_S)
188 if (($w > $T || $h > $T) && $face !~ /_S\./) { 462 if (($w > $T || $h > $T) && $face !~ /_S\./) {
189 # split 463 # split
190 my @tile; 464 my @tile;
… …
195 push @tile, [$x, $y, $file, (stat _)[9]]; 469 push @tile, [$x, $y, $file, (stat _)[9]];
196 } 470 }
197 } 471 }
198 472
199 my $mtime = (lstat $path)[9]; 473 my $mtime = (lstat $path)[9];
200 my @todo = grep { $_->[3] <= $mtime } @tile; 474 my @todo = grep { $_->[3] < $mtime } @tile;
201 if (@todo) { 475 if (@todo) {
202 fork_sub { 476 fork_exec {
203 open my $convert, "|-", $CONVERT, 477 open my $convert, "|-", $CONVERT,
204 "png:-", 478 "png:-",
205 (map { 479 (map {
206 ( 480 (
207 "(", 481 "(",
… …
220 print $convert $png; 494 print $convert $png;
221 close $convert; 495 close $convert;
222 496
223 # pass 2, optimise, and rename 497 # pass 2, optimise, and rename
224 for (@todo) { 498 for (@todo) {
225 system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~"; 499 optipng "$_->[2]~";
226 die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
227 rename "$_->[2]~", $_->[2]; 500 rename "$_->[2]~", $_->[2];
228 } 501 }
229 }; 502 };
230 } 503 }
231 504
… …
235 508
236 if (0 > aio_load $file, $tile) { 509 if (0 > aio_load $file, $tile) {
237 die "$path: unable to read tile +$x+$y, aborting.\n"; 510 die "$path: unable to read tile +$x+$y, aborting.\n";
238 } 511 }
239 IO::AIO::aio_unlink $file unless $CACHE; 512 IO::AIO::aio_unlink $file unless $CACHE;
240 commit_png $x|$y ? "$face+$x+$y" : $face, $tile, $T; 513 commit_png $stem, $x|$y ? "$face+$x+$y" : $face, $tile, $T, 1, 1;
241 } 514 }
242 } else { 515 } else {
243 # use as-is (either small, use smooth) 516 # use as-is (either small, use smooth)
244 commit_png $face, $png, $T; 517 commit_png $stem, $face, $png, $T, $w / $T, $h / $T;
245 } 518 }
246 519
247 aio_unlink $path if $delete; 520 IO::AIO::aio_unlink $path if $delete;
521 }
522 }
523
524 sub process_faceinfo {
525 my ($dir, $file) = @_;
526 my $path = "$dir/$file";
527
528 my $data;
529 if (0 > aio_load $path, $data) {
530 warn "ERROR: $path: $!, skipping.\n";
531 return;
532 }
533
534 for (split /\n/, $data) {
535 chomp;
536 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
537 # bg not used except for text clients
538
539 utf8::decode $glyph;
540 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag
541 $glyph =~ s/^"(.+)"$/$1/; # allow for ""-style quoting
542
543 $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet
544
545 (my $fgi = $COLOR{$fg})
546 // warn "ERROR: $path: $face specifies unknown foreground colour '$fg'.\n";
547 (my $bgi = $COLOR{$bg})
548 // warn "ERROR: $path: $face specifies unknown background colour '$bg'.\n";
549
550 my $fi = $FACEINFO{$face} ||= { };
551 $fi->{visibility} = $visibility * 1;
552 $fi->{magicmap} = $fgi; # foreground colour becomes magicmap
553
554 $glyph .= " " if 2 > length $glyph; # TODO kanji
555 die "glyph $face too long" if 2 < length $glyph;
556
557 $fi->{glyph} = "";
558 for (split //, $glyph) {
559 utf8::encode $_;
560 $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
561 }
248 } 562 }
249 } 563 }
250 564
251 sub process_arc { 565 sub process_arc {
252 while (@arc) { 566 while (my ($dir, $file) = @{ $c_arc->get }) {
253 my ($dir, $file) = @{pop @arc};
254
255 my $arc; 567 my $arc;
256 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/ 568 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
257 569
258 my $arc = read_arch "$dir/$file"; 570 my $arc = read_arch "$dir/$file";
259 for my $o (values %$arc) { 571 for my $o (values %$arc) {
572 push @ARC, $o;
573 for (my $m = $o; $m; $m = $m->{more}) {
260 $ARC{$o->{_name}} = $o; 574 $ARC{$m->{_name}} = $m;
575 }
261 576
262 $o->{editor_folder} = $dir; 577 $o->{editor_folder} ||= "\x00$dir"; # horrible kludge
263
264 my $visibility = delete $o->{visibility};
265 my $magicmap = delete $o->{magicmap};
266 578
267 # find upper left corner :/ 579 # find upper left corner :/
268 # omg, this is sooo broken 580 # omg, this is sooo broken
269 my ($dx, $dy); 581 my ($dx, $dy);
270 for (my $o = $o; $o; $o = $o->{more}) { 582 for (my $o = $o; $o; $o = $o->{more}) {
… …
277 my $y = $o->{y} - $dy; 589 my $y = $o->{y} - $dy;
278 590
279 my $ext = $x|$y ? "+$x+$y" : ""; 591 my $ext = $x|$y ? "+$x+$y" : "";
280 592
281 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face}; 593 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face};
282
283 my $visibility = delete $o->{visibility} if exists $o->{visibility};
284 my $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
285 594
286 my $anim = delete $o->{anim}; 595 my $anim = delete $o->{anim};
287 596
288 if ($anim) { 597 if ($anim) {
289 # possibly add $ext to the animation name to avoid 598 # possibly add $ext to the animation name to avoid
… …
307 facings => $facings, 616 facings => $facings,
308 frames => \@frames, 617 frames => \@frames,
309 }; 618 };
310 } 619 }
311 620
312 for my $face ($o->{face} || (), @{$anim || []}) { 621 for ($o->{face} || (), @{$anim || []}) {
622 next if /^facings\s/;
623
624 my $face = $_;
625 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
626
627 # handle derived faces
628 if ($face =~ /^([^:]+):(.*)/) {
629 my ($type, $base) = ($1, $2);
630 push @{ $FACEINFO{$base}{derive} }, [$dir, $type];
631 }
632
633 $FACEINFO{$face}{arc} = $o;
634
313 next if $face =~ /^facings\s|^blank.x11$|^empty.x11$/; 635 next if $face =~ /^blank.x11$|^empty.x11$/;
314
315 my $info = $FACEINFO{$face} ||= {};
316
317 $info->{visibility} = $visibility if defined $visibility;
318 $info->{magicmap} = $magicmap if defined $magicmap;
319 } 636 }
320 637
321 if (my $smooth = delete $o->{smoothface}) { 638 if (my $smooth = delete $o->{smoothface}) {
322 my %kv =split /\s+/, $smooth; 639 my %kv = split /\s+/, $smooth;
323 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 640 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
324 while (my ($face, $smooth) = each %kv) { 641 while (my ($face, $smooth) = each %kv) {
642 $FACEINFO{$smooth}{arc} = $o;
643
325 $FACEINFO{$face}{smooth} = $smooth; 644 $FACEINFO{$face}{smooth} = $smooth;
326 $FACEINFO{$face}{smoothlevel} = $level; 645 $FACEINFO{$face}{smoothlevel} = $level;
327 } 646 }
328 } 647 }
329 } 648 }
330 } 649 }
331 } 650 }
332 } 651 }
333 652
334 sub process_trs { 653 sub process_trs {
335 while (@trs) {
336 my ($dir, $file) = @{pop @trs}; 654 my ($dir, $file) = @_;
337 my $path = "$dir/$file"; 655 my $path = "$dir/$file";
338 656
339 my $trs; 657 my $trs;
340 if (0 > aio_load $path, $trs) { 658 if (0 > aio_load $path, $trs) {
341 warn "$path: $!, skipping.\n"; 659 warn "ERROR: $path: $!, skipping.\n";
660 return;
661 }
662
663 $TRS .= $trs;
664 }
665
666 my %FILECACHE;
667
668 sub load_cached($;$) {
669 unless (exists $FILECACHE{$_[0]}) {
670 my $data;
671 if (0 < aio_load $_[0], $data) {
672 if ($_[1]) {
673 $data = eval { $_[1]->($data) };
674 warn "ERROR: $_[0]: $@" if $@;
342 next; 675 }
676 }
677
678 $FILECACHE{$_[0]} = $data;
679 }
680
681 $FILECACHE{$_[0]}
682 }
683
684 # convert an image and a palette to some indexed 2d-matrix structure
685 sub process_plt {
686 my ($base, $plt) = @_;
687
688 my ($w, $h) = imgsize "$base.png";
689
690 $w * $h
691 or die "$base.png: unable to identify correct size\n";
692
693 my @plt;
694 my %map;
695
696 for (split /\n/, $plt) {
697 next unless /\S/;
698 next if /^\s*#/;
699
700 /^([0-9a-fA-F]{3,6})\s*(.*?)\s*$/
701 or die "unparseable palette entry for $base.plt: $_";
702
703 my ($rgb, $name) = ($1, $2);
704
705 $rgb =~ s/^(.)(.)(.)$/$1$1$2$2$3$3/;
706
707 $map{pack "H*", $rgb} = chr @plt;
708 push @plt, $name;
709 }
710
711 make_file ["$base.plt", "$base.png"], "$base.tbl~", sub {
712 warn "building $base\n" if $VERBOSE >= 3;
713
714 fork_exec {
715 open my $png, "-|", $CONVERT, qw(-depth 8 --), "$base.png", "rgb:"
716 or die "$base.png: $!";
717
718 local $/;
719 $png = <$png>;
720
721 $w * $h * 3 == length $png
722 or die "$base.png: failed to read enough data from file\n";
723
724 $png =~ s/(...)/$map{$1}/ge;
725
726 $w * $h == length $png
727 or die "$base.png: failed to map all data - wrong palette?\n";
728
729 {
730 open my $fh, ">:raw", "$base.tbl~~"
731 or die "$base.tbl~~: $!";
732 syswrite $fh, $png;
733 }
734
735 rename "$base.tbl~~", "$base.tbl~";
343 } 736 };
737 };
344 738
345 $TRS .= $trs; 739 0 <= aio_load "$base.tbl~", my $tbl
740 or die "$base.tbl~: $!";
741
742 IO::AIO::aio_unlink "$base.tbl~" unless $CACHE;
743
744 Compress::LZF::compress nfreeze {
745 w => $w,
746 h => $h,
747 plt => \@plt,
748 tbl => $tbl,
749 }
750 }
751
752 sub process_res {
753 my ($dir, $file, $type) = @_;
754
755 0 <= aio_load "$dir/$file", my $data
756 or die "$dir/$file: $!";
757
758 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
759
760 utf8::decode $dir;
761 utf8::decode $file;
762
763 # a meta file for resources is now mandatory
764 unless (exists $meta->{$file}) {
765 warn "skipping $dir/$file\n" if $VERBOSE >= 3;
766 return;
767 }
768
769 $meta = {
770 %{ $meta->{"" } || {} },
771 %{ $meta->{$file} || {} },
772 };
773
774 if (exists $meta->{license} && $meta->{license} =~ s/^#//) { # exists == avoid autovivification
775 # all these are acceptable for deliantra - if not specified, agpl 3+ is the default.
776 $meta->{license} = ({
777 "pd" => "Public Domain",
778 "gpl" => "GNU General Public License, version 3.0 or any later",
779 "2bsd" => "2-clause BSD/MIT style license",
780 "3bsd" => "3-clause BSD style license",
781 "cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
782 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
783 "cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
784 "cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
785 })->{$meta->{license}}
786 || warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
787 }
788
789 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
790 ($meta->{author} = $1) =~ s/_/ /g;
791 }
792
793 $file =~ s/\.res$//;
794 $file =~ s/\.(ogg|wav|jpg|png)$//;
795
796 if ($file =~ s/\.plt$//) {
797 $data = process_plt "$dir/$file", $data;
798 } elsif (my $filter = delete $meta->{cfutil_filter}) {
799 if ($filter eq "yaml2json") {
800 $data = JSON::XS::encode_json YAML::XS::Load $data;
801 } elsif ($filter eq "json2json") {
802 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
803 } elsif ($filter eq "perl2json") {
804 $data = eval $data; die if $@;
805 $data = JSON::XS::encode_json $data;
806 } else {
807 warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
808 }
809 }
810
811 substr $dir, 0, 1 + length $PATH, "";
812
813 my %info = (
814 type => (exists $meta->{type} ? delete $meta->{type} : $type),
815 data => $data,
816 %$meta ? (meta => $meta) : (),
817 );
818
819 $RESOURCE{"$dir/$file"} = \%info;
820 }
821
822 sub process_any {
823 while (my ($func, @args) = @{ $c_any->get }) {
824 $func->(@args);
346 } 825 }
347 } 826 }
348 827
349 sub find_files; 828 sub find_files;
350 sub find_files { 829 sub find_files {
351 my ($path) = @_; 830 my ($path) = @_;
352 831
832 my $grp = IO::AIO::aio_group;
833
834 my $scandir; $scandir = sub {
835 my ($path) = @_;
836
353 IO::AIO::aioreq_pri 4; 837 IO::AIO::aioreq_pri 4;
354 IO::AIO::aio_scandir $path, 4, sub { 838 add $grp IO::AIO::aio_scandir $path, 4, sub {
355 my ($dirs, $nondirs) = @_; 839 my ($dirs, $nondirs) = @_;
356 840
357 find_files "$path/$_" 841 $scandir->("$path/$_")
358 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs; 842 for grep $_ !~ /^(?:CVS|dev|\..*)$/, @$dirs;
359 843
844 my $dir = $path;
845 substr $dir, 0, 1 + length $PATH, "";
846
360 for my $file (@$nondirs) { 847 for my $file (@$nondirs) {
848 if ($dir =~ /^music(?:\/|$)/) {
849 $c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
850 if $file =~ /\.(ogg)$/;
851
852 } elsif ($dir =~ /^sound(?:\/|$)/) {
853 $c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
854 if $file =~ /\.(wav|ogg)$/;
855
856 } elsif ($dir =~ /^res(?:\/|$)/) {
857 if ($file =~ /\.(jpg|png)$/) {
858 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
859 } elsif ($file =~ /\.(res)$/) {
860 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
861 } else {
862 $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
863 }
864
361 if ($file =~ /\.png$/) { 865 } elsif ($file =~ /\.png$/) {
362 push @png, ["$path/$file", 0]; 866 $PNG{$file} = $path;
867
868 } elsif ($file =~ /\.faceinfo$/) {
869 $c_any->put ([\&process_faceinfo, $path, $file]);
870
363 } elsif ($file =~ /\.trs$/) { 871 } elsif ($file =~ /\.trs$/) {
364 push @trs, [$path, $file]; 872 $c_any->put ([\&process_trs, $path, $file]);
873
365 } elsif ($file =~ /\.arc$/) { 874 } elsif ($file =~ /\.arc$/) {
366 push @arc, [$path, $file]; 875 $c_arc->put ([$path, $file]);
876
367 } else { 877 } else {
368 warn "ignoring $path/$file\n" if $VERBOSE >= 2; 878 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
369 } 879 }
880 }
370 } 881 };
371 }; 882 };
883
884 $scandir->($path);
885 aio_wait $grp;
886 }
887
888 sub generate_plurals {
889# use Lingua::EN::Inflect ();
890# Lingua::EN::Inflect::classical;
891# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
892# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
893#
894# for my $a (@ARC) {
895# my $name = $a->{name} || $a->{_name};
896#
897# next unless $a->{name_pl};
898# next if $a->{invisible};
899# next if $a->{is_floor};
900# next if $a->{no_pick};
901#
902# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
903# my $pl = $test =~ /^(?:eq|p:.)$/
904# ? $name
905# : Lingua::EN::Inflect::PL $name;
906#
907# if ($pl ne $a->{name_pl}) {
908# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
909# }
910# }
372 } 911 }
373 912
374 sub inst_arch($) { 913 sub inst_arch($) {
375 my (undef, $path) = @_; 914 my (undef, $path) = @_;
376 915
916 $PATH = $path;
917
918 print "\n",
377 print "Installing '$path' to '$DATADIR'\n", 919 "Installing '$path' to '$DATADIR'\n",
920 "\n",
378 "This can take a long time if you run this\n", 921 "This can take a long time if you run this\n",
379 "for the first time or do not use --cache.\n", 922 "for the first time or do not use --cache.\n",
380 "\n", 923 "\n",
381 "Unless you run verbosely, all following warning\n", 924 "Unless you run verbosely, all following warning\n",
382 "or error messages indicate serious problems.\n", 925 "or error messages indicate serious problems.\n",
383 "\n"; 926 "\n";
384 927
385 if (!-d "$path/treasures") { 928 if (!-d "$path/treasures") {
386 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 929 warn "FATAL: '$path' does not look like an arch directory ('treasures' directory is missing).\n";
387 exit 1 unless $FORCE; 930 exit 1 unless $FORCE;
388 } 931 }
389 932
933 print "starting file scan, arc, any processing...\n" if $VERBOSE;
934
935 my @a_arc = map +(async \&process_arc), 1..2;
936 my @a_any = map +(async \&process_any), 1..4;
937
390 find_files $path; 938 find_files $path;
391 IO::AIO::flush;
392 939
393 $_->join for ( 940 $c_arc->shutdown;
941 $c_any->shutdown;
942
943 $_->join for @a_arc; # need to parse all archetypes before png processing
944 print "finished arc processing...\n" if $VERBOSE;
945
946 # fill png queue
947 for (keys %FACEINFO) {
948 # we only expect source pngs to exist for non-derived
949 # faces, i.e. no split tiles (+x+x) and no face derivates
950 # (xxx:)
951 /^[^:]+\....$/
952 or next;
953
954 my $seen;
955
956 if (exists $PNG{"$_.32x32.png"}) {
957 push @c_png, ["$PNG{\"$_.32x32.png\"}/$_.32x32.png"];
958 $seen = 1;
959 }
960 if (exists $PNG{"$_.64x64.png"}) {
961 push @c_png, ["$PNG{\"$_.64x64.png\"}/$_.64x64.png"];
962 $seen = 1;
963 }
964
965 warn "ERROR: $_: face not found, expect problems.\n"
966 unless $seen;
967 }
968
969 print "starting png processing...\n" if $VERBOSE;
970
394 # four png crunchers work fine for my 2x smp machine 971 # eight png crunchers work fine for my 4x smp machine
395 (async \&process_png), (async \&process_png), (async \&process_png), (async \&process_png), 972 my @a_png = map +(async \&process_png), 1..8;
396 (async \&process_trs), (async \&process_trs),
397 (async \&process_arc), (async \&process_arc),
398 );
399 973
974 $_->join for @a_any;
975 print "finished any processing...\n" if $VERBOSE;
976
977 $_->join for @a_png;
978 print "finished png processing...\n" if $VERBOSE;
979
980 print "scanning done, processing results...\n" if $VERBOSE;
400 { 981 {
401 # remove path prefix from editor_folder 982 # remove path prefix from editor_folder
983 $_->{editor_folder} =~ /^\x00/
402 substr $_->{editor_folder}, 0, 1 + length $path, "" 984 and substr $_->{editor_folder}, 0, 2 + length $path, ""
403 for values %ARC; 985 for values %ARC;
404 986
987 print "resolving inheritance tree...\n" if $VERBOSE;
405 # resolve inherit 988 # resolve inherit
406 while () { 989 while () {
407 my $progress; 990 my $progress;
408 my $loop; 991 my $loop;
409 992
410 for my $o (values %ARC) { 993 for my $o (values %ARC) {
411 if (my $other = $o->{inherit}) { 994 for my $other (split /,/, $o->{inherit}) {
412 if (my $s = $ARC{$other}) { 995 if (my $s = $ARC{$other}) {
413 if ($s->{inherit}) { 996 if ($s->{inherit}) {
414 $loop = $s; 997 $loop = $s;
415 } else { 998 } else {
416 delete $o->{inherit}; 999 delete $o->{inherit};
1000 my %s = %$s;
1001 delete @s{qw(_name more name name_pl)};
417 %$o = ( %$s, %$o ); 1002 %$o = ( %s, %$o );
418 ++$progress; 1003 ++$progress;
419 } 1004 }
420 } else { 1005 } else {
421 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n"; 1006 warn "ERROR: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
422 delete $ARC{$o->{_name}}; 1007 delete $ARC{$o->{_name}};
423 } 1008 }
424 } 1009 }
425 } 1010 }
426 1011
… …
430 1015
431 last; 1016 last;
432 } 1017 }
433 } 1018 }
434 1019
1020 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
1021 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC;
1022
1023 # fix up archetypes without names, where the archanme doesn't work at all
1024 for (@ARC) {
1025 if (!exists $_->{name} and $_->{_name} =~ /_/) {
1026 for ($_->{name} = $_->{_name}) {
1027 s/(?:_\d+)+$//;
1028 s/_[nesw]+$//;
1029 y/_/ /;
1030 }
1031 }
1032 }
1033
1034 #print "generating plurals...\n" if $VERBOSE;
1035 #generate_plurals;
1036
1037 printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
435 open my $fh, ">:utf8", "$DATADIR/archetypes~" 1038 open my $fh, ">:utf8", "$DATADIR/archetypes~"
436 or die "$DATADIR/archetypes~: $!"; 1039 or die "$DATADIR/archetypes~: $!";
437 print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } values %ARC]; 1040 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
438 } 1041 }
439 1042
440 { 1043 {
1044 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
441 open my $fh, ">:utf8", "$DATADIR/treasures~" 1045 open my $fh, ">:utf8", "$DATADIR/treasures~"
442 or die "$DATADIR/treasures~: $!"; 1046 or die "$DATADIR/treasures~: $!";
443 print $fh $TRS; 1047 print $fh $TRS;
444 } 1048 }
445 1049
446 { 1050 {
447 while (my ($k, $v) = each %FACEINFO) { 1051 print "processing facedata...\n" if $VERBOSE;
448 length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
449 length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
450
451 length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";
452 #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
453
454 $v->{chksum32} = Digest::MD5::md5 $v->{data32};
455 $v->{chksum64} = Digest::MD5::md5 $v->{data64};
456 } 1052
1053 for my $k (sort keys %FACEINFO) {
1054 my $v = $FACEINFO{$k};
457 1055
1056 length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
1057 length $v->{data64} or warn "ERROR: face '$k' has no png64 - this will not work.\n";
1058
1059 make_hash $k, $v->{data32}, $v->{hash32};
1060 make_hash $k, $v->{data64}, $v->{hash64};
1061
1062 #length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
1063 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
1064
1065 $v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
1066 $v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
1067 $v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
1068
1069 if (0 && $v->{w} == 1 && $v->{h} == 1) { # texture catalogs
1070 my $id = @TC;
1071 my $n = @{ $TC[-1] };
1072 my $x = $n % TC_W;
1073 my $y = int $n / TC_W;
1074
1075 push @{ $TC[-1] }, [$v, $x, $y];
1076
1077 $v->{tc} = [$id, $x, $y];
1078
1079 push @TC, [] if $n == TC_W * TC_H - 1; # start new texture if full
1080 }
1081
1082 delete @$v{qw(w h arc stem derive)}; # not used by the server
1083 }
1084
1085if (0) { #d# texture catalogs
1086 print "creating texture catalogs...\n" if $VERBOSE;
1087
1088 for my $id (0 .. $#TC) {
1089 my $tc = $TC[$id];
1090
1091 my $cmd = "$CONVERT -depth 8 -size " . (TC_W * 64) . "x" . (TC_H * 64) . " xc:transparent";
1092 my $idx = "a";
1093
1094 for (@$tc) {
1095 my $path = "$TMPDIR/tc" . $idx++;
1096
1097 open my $fh, ">:perlio", $path
1098 or die "$path: $!";
1099 syswrite $fh, $_->[0]{data64};
1100
1101 my $x = $_->[1] * 64;
1102 my $y = $_->[2] * 64;
1103
1104 $cmd .= " png:\Q$path\E -geometry +$x+$y -composite";
1105 }
1106
1107 system "$cmd png:\Q$TMPDIR/tc$id\E";
1108 optipng "$TMPDIR/tc$id";
1109 }
1110}
1111
1112 print "processing resources...\n" if $VERBOSE;
1113 my $enc = JSON::XS->new->utf8->canonical->relaxed;
1114 for my $k (sort keys %RESOURCE) {
1115 my $v = $RESOURCE{$k};
1116
1117 if ($v->{meta} && $v->{meta}{datadir}) {
1118 delete $RESOURCE{$k};
1119
1120 $k =~ s/^res\/// or die "$k: datadir files must be in res/";
1121
1122 printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
1123 open my $fh, ">:raw", "$DATADIR/$k~"
1124 or die "$DATADIR/$k~: $!";
1125 syswrite $fh, $v->{data};
1126 push @COMMIT, $k;
1127
1128 } else {
1129 if ($v->{type} & 1) {
1130 # prepend meta info
1131
1132 my $meta = $enc->encode ({
1133 name => $k,
1134 %{ $v->{meta} || {} },
1135 });
1136
1137 $v->{data} = pack "(w/a*)*", $meta, $v->{data};
1138 }
1139
1140 make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
1141 }
1142 }
1143
1144 printf "writing facedata...\n" if $VERBOSE;
1145
1146 {
458 open my $fh, ">:perlio", "$DATADIR/facedata~" 1147 open my $fh, ">:perlio", "$DATADIR/facedata~"
459 or die "$DATADIR/facedata~: $!"; 1148 or die "$DATADIR/facedata~: $!";
460 1149
1150 print $fh "FACEDATA";
1151 my $fofs = 8;
1152
1153 my $put = sub {
1154 my $len = length $_[0];
1155 my $ofs = $fofs;
1156
1157 print $fh $_[0];
1158 $fofs += $len;
1159
1160 ($len, $ofs)
1161 };
1162
1163 for (values %FACEINFO) {
1164 ($_->{size32}, $_->{fofs32}) = $put->(delete $_->{data32});
1165 ($_->{size64}, $_->{fofs64}) = $put->(delete $_->{data64});
1166 }
1167
1168 for (values %RESOURCE) {
1169 ($_->{size}, $_->{fofs}) = $put->(delete $_->{data});
1170 }
1171
1172 close $fh;
1173 }
1174
1175 printf "writing faceinfo (%d faces, %d anims, %d resources)...\n",
1176 scalar keys %FACEINFO,
1177 scalar keys %ANIMINFO,
1178 scalar keys %RESOURCE
1179 if $VERBOSE;
1180
1181 open my $fh, ">:perlio", "$DATADIR/faceinfo~"
1182 or die "$DATADIR/faceinfo~: $!";
1183
461 print $fh freeze { 1184 print $fh nfreeze {
462 version => 2, 1185 version => 2,
463 faceinfo => \%FACEINFO, 1186 faceinfo => \%FACEINFO,
464 animinfo => \%ANIMINFO, 1187 animinfo => \%ANIMINFO,
1188 resource => \%RESOURCE,
465 }; 1189 };
466 } 1190 }
467 1191
1192 print "committing files...\n" if $VERBOSE;
1193
468 for (qw(archetypes facedata treasures)) { 1194 for (qw(archetypes faceinfo facedata treasures), @COMMIT) {
469 chmod 0644, "$DATADIR/$_~"; 1195 chmod 0644, "$DATADIR/$_~";
470 rename "$DATADIR/$_~", "$DATADIR/$_" 1196 rename "$DATADIR/$_~", "$DATADIR/$_"
471 or die "$DATADIR/$_: $!"; 1197 or die "$DATADIR/$_: $!";
472 } 1198 }
473 1199

Diff Legend

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