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.30 by root, Sat Apr 21 11:55:36 2007 UTC vs.
Revision 1.123 by root, Sun Nov 11 04:29:11 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 "\nInstalling '$path' to '$DATADIR/maps'\n\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;
89 our @ARC; 212 our @ARC;
90 our %ARC; 213 our %ARC;
91 our $TRS; 214 our $TRS;
215 our %PNG;
92 our $NFILE; 216 our $NFILE;
217 our $PATH;
93 218
94 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 219 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
95 220
96 our (@png, @trs, @arc); # files we are interested in 221 our $c_arc = new Coro::Channel;
222 our $c_any = new Coro::Channel;
97 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
98 sub commit_png($$$) { 232 sub commit_png($$$$$$) {
99 my ($name, $data, $T) = @_; 233 my ($stem, $name, $data, $T, $w, $h) = @_;
100 234
235 $FACEINFO{$name}{stem} = substr $stem, 1 + length $PATH;
101 $FACEINFO{$name}{"data$T"} = $data; 236 $FACEINFO{$name}{"data$T"} = $data;
237 $FACEINFO{$name}{w} = $w;
238 $FACEINFO{$name}{h} = $h;
102 } 239 }
103 240
104 sub process_png { 241 sub process_png {
105 while (@png) { 242 while (@c_png) {
106 my ($path, $delete) = @{pop @png}; 243 my ($path, $delete) = @{pop @c_png};
107 244
108 my $png; 245 my $png;
109 aio_lstat $path; 246 aio_lstat $path;
110 my ($size, $mtime) = (stat _)[7,9]; 247 my ($size, $mtime) = (stat _)[7,9];
111 248
112 if (0 > aio_load $path, $png) { 249 if (0 > aio_load $path, $png) {
113 warn "$path: $!, skipping.\n"; 250 warn "ERROR: $path: $!, skipping.\n";
114 next; 251 next;
115 } 252 }
116 253
117 my $stem = $path; 254 my $stem = $path;
118 my $T; 255 my $T;
… …
120 if ($stem =~ s/\.32x32\.png~?$//) { 257 if ($stem =~ s/\.32x32\.png~?$//) {
121 $T = 32; 258 $T = 32;
122 } elsif ($stem =~ s/\.64x64\.png~?$//) { 259 } elsif ($stem =~ s/\.64x64\.png~?$//) {
123 $T = 64; 260 $T = 64;
124 } else { 261 } else {
125 warn "$path: weird filename, skipping.\n"; 262 warn "ERROR: $path: weird filename, skipping.\n";
126 next; 263 next;
127 } 264 }
128 265
129 # quickly extract width and height of the (necessarily PNG) image 266 # quickly extract width and height of the (necessarily PNG) image
130 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) { 267 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
131 warn "$path: not a recognized png file, skipping.\n"; 268 warn "ERROR: $path: not a recognized png file, skipping.\n";
132 next; 269 next;
133 } 270 }
134 271
135 my ($w, $h) = unpack "NN", $1; 272 my ($w, $h) = unpack "NN", $1;
136 273
137 if ($w < $T || $h < $T) { 274 if ($w < $T || $h < $T) {
138 warn "$path: too small ($w $h), skipping.\n"; 275 warn "ERROR: $path: too small ($w $h), skipping.\n";
139 next; 276 next;
140 } 277 }
141 278
142 if ($w % $T || $h % $T) { 279 if ($w % $T || $h % $T) {
143 warn "$path: weird png size ($w $h), skipping.\n"; 280 warn "ERROR: $path: weird png size ($w $h), skipping.\n";
144 next; 281 next;
145 } 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} || { };
146 293
147 unless ($path =~ /~$/) { 294 unless ($path =~ /~$/) {
148 # possibly enlarge 295 # possibly enlarge
149 if (0 > aio_stat "$stem.64x64.png") { 296 if (0 > aio_stat "$stem.64x64.png") {
150 my $other = "$stem.64x64.png~"; 297 my $other = "$stem.64x64.png~";
151 298
152 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 299 make_file $path, $other, sub {
153 my $wrap = 0; # for the time being
154 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
155 system "convert png:\Q$path\E -depth 8 rgba:-" 360 system "$CONVERT -depth 8 $SRC rgba:-"
156 . "| $exec_prefix/bin/cfhq2xa $w $h $wrap" 361 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
157 . "| 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~"
158 and die "convert/hq2xa pipeline error: status $? ($!)"; 363 and die "convert/cfhq2xa pipeline error: status $? ($!)";
159 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
160 die "$other~ has zero size, aborting." unless -s "$other~"; 399 die "$other~ has zero size, aborting." unless -s "$other~";
161 rename "$other~", $other; 400 rename "$other~", $other;
162 }; 401 };
163 } 402 };
164 403
404 #warn "scaled down $path to $other\n";#d#
165 push @png, [$other, !$CACHE]; 405 push @c_png, [$other, !$CACHE];
406 }
166 } 407 }
167 408
168 # possibly scale down 409 (my $face = $stem) =~ s/^.*\///;
169 if (0 > aio_stat "$stem.32x32.png") {
170 my $other = "$stem.32x32.png~";
171 410
172 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 {
173 fork_sub { 420 fork_exec {
174 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~";
175 system $OPTIPNG, "-o5", "-i0", "-q", "$other~"; 422 optipng "$dpath~";
176 die "$other~ has zero size, aborting." unless -s "$other~";
177 rename "$other~", $other; 423 rename "$dpath~", $dpath;
178 }; 424 };
179 } 425 };
180 426 } elsif ($type eq "buildmaterial-box") {
181 #warn "scaled down $path to $other\n";#d# 427 my $ov = "$PATH/mapbuilding/buildmaterial-box.png";
182 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 };
183 } 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";
184 } 454 }
185 455
186 (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 }
187 460
188 # split all bigfaces, but avoid smoothfaces (*_S) 461 # split all bigfaces, but avoid smoothfaces (*_S)
189 if (($w > $T || $h > $T) && $face !~ /_S\./) { 462 if (($w > $T || $h > $T) && $face !~ /_S\./) {
190 # split 463 # split
191 my @tile; 464 my @tile;
… …
196 push @tile, [$x, $y, $file, (stat _)[9]]; 469 push @tile, [$x, $y, $file, (stat _)[9]];
197 } 470 }
198 } 471 }
199 472
200 my $mtime = (lstat $path)[9]; 473 my $mtime = (lstat $path)[9];
201 my @todo = grep { $_->[3] <= $mtime } @tile; 474 my @todo = grep { $_->[3] < $mtime } @tile;
202 if (@todo) { 475 if (@todo) {
203 fork_sub { 476 fork_exec {
204 open my $convert, "|-", $CONVERT, 477 open my $convert, "|-", $CONVERT,
205 "png:-", 478 "png:-",
206 (map { 479 (map {
207 ( 480 (
208 "(", 481 "(",
… …
221 print $convert $png; 494 print $convert $png;
222 close $convert; 495 close $convert;
223 496
224 # pass 2, optimise, and rename 497 # pass 2, optimise, and rename
225 for (@todo) { 498 for (@todo) {
226 system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~"; 499 optipng "$_->[2]~";
227 die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
228 rename "$_->[2]~", $_->[2]; 500 rename "$_->[2]~", $_->[2];
229 } 501 }
230 }; 502 };
231 } 503 }
232 504
… …
236 508
237 if (0 > aio_load $file, $tile) { 509 if (0 > aio_load $file, $tile) {
238 die "$path: unable to read tile +$x+$y, aborting.\n"; 510 die "$path: unable to read tile +$x+$y, aborting.\n";
239 } 511 }
240 IO::AIO::aio_unlink $file unless $CACHE; 512 IO::AIO::aio_unlink $file unless $CACHE;
241 commit_png $x|$y ? "$face+$x+$y" : $face, $tile, $T; 513 commit_png $stem, $x|$y ? "$face+$x+$y" : $face, $tile, $T, 1, 1;
242 } 514 }
243 } else { 515 } else {
244 # use as-is (either small, use smooth) 516 # use as-is (either small, use smooth)
245 commit_png $face, $png, $T; 517 commit_png $stem, $face, $png, $T, $w / $T, $h / $T;
246 } 518 }
247 519
248 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 }
249 } 562 }
250 } 563 }
251 564
252 sub process_arc { 565 sub process_arc {
253 while (@arc) { 566 while (my ($dir, $file) = @{ $c_arc->get }) {
254 my ($dir, $file) = @{pop @arc};
255
256 my $arc; 567 my $arc;
257 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 :/
258 569
259 my $arc = read_arch "$dir/$file"; 570 my $arc = read_arch "$dir/$file";
260 for my $o (values %$arc) { 571 for my $o (values %$arc) {
261 push @ARC, $o; 572 push @ARC, $o;
262 for (my $m = $o; $m; $m = $m->{more}) { 573 for (my $m = $o; $m; $m = $m->{more}) {
263 $ARC{$m->{_name}} = $m; 574 $ARC{$m->{_name}} = $m;
264 } 575 }
265 576
266 $o->{editor_folder} = $dir; 577 $o->{editor_folder} ||= "\x00$dir"; # horrible kludge
267
268 my $visibility = delete $o->{visibility};
269 my $magicmap = delete $o->{magicmap};
270 578
271 # find upper left corner :/ 579 # find upper left corner :/
272 # omg, this is sooo broken 580 # omg, this is sooo broken
273 my ($dx, $dy); 581 my ($dx, $dy);
274 for (my $o = $o; $o; $o = $o->{more}) { 582 for (my $o = $o; $o; $o = $o->{more}) {
… …
281 my $y = $o->{y} - $dy; 589 my $y = $o->{y} - $dy;
282 590
283 my $ext = $x|$y ? "+$x+$y" : ""; 591 my $ext = $x|$y ? "+$x+$y" : "";
284 592
285 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face}; 593 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face};
286
287 my $visibility = delete $o->{visibility} if exists $o->{visibility};
288 my $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
289 594
290 my $anim = delete $o->{anim}; 595 my $anim = delete $o->{anim};
291 596
292 if ($anim) { 597 if ($anim) {
293 # possibly add $ext to the animation name to avoid 598 # possibly add $ext to the animation name to avoid
… …
311 facings => $facings, 616 facings => $facings,
312 frames => \@frames, 617 frames => \@frames,
313 }; 618 };
314 } 619 }
315 620
316 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
317 next if $face =~ /^facings\s|^blank.x11$|^empty.x11$/; 635 next if $face =~ /^blank.x11$|^empty.x11$/;
318
319 my $info = $FACEINFO{$face} ||= {};
320
321 $info->{visibility} = $visibility if defined $visibility;
322 $info->{magicmap} = $magicmap if defined $magicmap;
323 } 636 }
324 637
325 if (my $smooth = delete $o->{smoothface}) { 638 if (my $smooth = delete $o->{smoothface}) {
326 my %kv =split /\s+/, $smooth; 639 my %kv = split /\s+/, $smooth;
327 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 640 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
328 while (my ($face, $smooth) = each %kv) { 641 while (my ($face, $smooth) = each %kv) {
642 $FACEINFO{$smooth}{arc} = $o;
643
329 $FACEINFO{$face}{smooth} = $smooth; 644 $FACEINFO{$face}{smooth} = $smooth;
330 $FACEINFO{$face}{smoothlevel} = $level; 645 $FACEINFO{$face}{smoothlevel} = $level;
331 } 646 }
332 } 647 }
333 } 648 }
334 } 649 }
335 } 650 }
336 } 651 }
337 652
338 sub process_trs { 653 sub process_trs {
339 while (@trs) {
340 my ($dir, $file) = @{pop @trs}; 654 my ($dir, $file) = @_;
341 my $path = "$dir/$file"; 655 my $path = "$dir/$file";
342 656
343 my $trs; 657 my $trs;
344 if (0 > aio_load $path, $trs) { 658 if (0 > aio_load $path, $trs) {
345 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 $@;
346 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~";
347 } 736 };
737 };
348 738
349 $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 $meta->{license} = ({
776 "pd" => "Public Domain",
777 "gpl" => "GNU General Public License, version 3.0 or any later",
778 "cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
779 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
780 "cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
781 "cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
782 })->{$meta->{license}}
783 || warn "ERROR: $dir/$file: license tag '$meta->{license}' not found.";
784 }
785
786 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
787 ($meta->{author} = $1) =~ s/_/ /g;
788 }
789
790 $file =~ s/\.res$//;
791 $file =~ s/\.(ogg|wav|jpg|png)$//;
792
793 if ($file =~ s/\.plt$//) {
794 $data = process_plt "$dir/$file", $data;
795 } elsif (my $filter = delete $meta->{cfutil_filter}) {
796 if ($filter eq "yaml2json") {
797 $data = JSON::XS::encode_json YAML::XS::Load $data;
798 } elsif ($filter eq "json2json") {
799 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
800 } elsif ($filter eq "perl2json") {
801 $data = eval $data; die if $@;
802 $data = JSON::XS::encode_json $data;
803 } else {
804 warn "ERROR: $dir/$file: unknown filter $filter, skipping\n";
805 }
806 }
807
808 substr $dir, 0, 1 + length $PATH, "";
809
810 my %info = (
811 type => (exists $meta->{type} ? delete $meta->{type} : $type),
812 data => $data,
813 %$meta ? (meta => $meta) : (),
814 );
815
816 $RESOURCE{"$dir/$file"} = \%info;
817 }
818
819 sub process_any {
820 while (my ($func, @args) = @{ $c_any->get }) {
821 $func->(@args);
350 } 822 }
351 } 823 }
352 824
353 sub find_files; 825 sub find_files;
354 sub find_files { 826 sub find_files {
355 my ($path) = @_; 827 my ($path) = @_;
356 828
829 my $grp = IO::AIO::aio_group;
830
831 my $scandir; $scandir = sub {
832 my ($path) = @_;
833
357 IO::AIO::aioreq_pri 4; 834 IO::AIO::aioreq_pri 4;
358 IO::AIO::aio_scandir $path, 4, sub { 835 add $grp IO::AIO::aio_scandir $path, 4, sub {
359 my ($dirs, $nondirs) = @_; 836 my ($dirs, $nondirs) = @_;
360 837
361 find_files "$path/$_" 838 $scandir->("$path/$_")
362 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs; 839 for grep $_ !~ /^(?:CVS|dev|\..*)$/, @$dirs;
363 840
841 my $dir = $path;
842 substr $dir, 0, 1 + length $PATH, "";
843
364 for my $file (@$nondirs) { 844 for my $file (@$nondirs) {
845 if ($dir =~ /^music(?:\/|$)/) {
846 $c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
847 if $file =~ /\.(ogg)$/;
848
849 } elsif ($dir =~ /^sound(?:\/|$)/) {
850 $c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
851 if $file =~ /\.(wav|ogg)$/;
852
853 } elsif ($dir =~ /^res(?:\/|$)/) {
854 if ($file =~ /\.(jpg|png)$/) {
855 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
856 } elsif ($file =~ /\.(res)$/) {
857 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
858 } else {
859 $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
860 }
861
365 if ($file =~ /\.png$/) { 862 } elsif ($file =~ /\.png$/) {
366 push @png, ["$path/$file", 0]; 863 $PNG{$file} = $path;
864
865 } elsif ($file =~ /\.faceinfo$/) {
866 $c_any->put ([\&process_faceinfo, $path, $file]);
867
367 } elsif ($file =~ /\.trs$/) { 868 } elsif ($file =~ /\.trs$/) {
368 push @trs, [$path, $file]; 869 $c_any->put ([\&process_trs, $path, $file]);
870
369 } elsif ($file =~ /\.arc$/) { 871 } elsif ($file =~ /\.arc$/) {
370 push @arc, [$path, $file]; 872 $c_arc->put ([$path, $file]);
873
371 } else { 874 } else {
372 warn "ignoring $path/$file\n" if $VERBOSE >= 2; 875 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
373 } 876 }
877 }
374 } 878 };
375 }; 879 };
880
881 $scandir->($path);
882 aio_wait $grp;
883 }
884
885 sub generate_plurals {
886# use Lingua::EN::Inflect ();
887# Lingua::EN::Inflect::classical;
888# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
889# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
890#
891# for my $a (@ARC) {
892# my $name = $a->{name} || $a->{_name};
893#
894# next unless $a->{name_pl};
895# next if $a->{invisible};
896# next if $a->{is_floor};
897# next if $a->{no_pick};
898#
899# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
900# my $pl = $test =~ /^(?:eq|p:.)$/
901# ? $name
902# : Lingua::EN::Inflect::PL $name;
903#
904# if ($pl ne $a->{name_pl}) {
905# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
906# }
907# }
376 } 908 }
377 909
378 sub inst_arch($) { 910 sub inst_arch($) {
379 my (undef, $path) = @_; 911 my (undef, $path) = @_;
912
913 $PATH = $path;
380 914
381 print "\n", 915 print "\n",
382 "Installing '$path' to '$DATADIR'\n", 916 "Installing '$path' to '$DATADIR'\n",
383 "\n", 917 "\n",
384 "This can take a long time if you run this\n", 918 "This can take a long time if you run this\n",
… …
387 "Unless you run verbosely, all following warning\n", 921 "Unless you run verbosely, all following warning\n",
388 "or error messages indicate serious problems.\n", 922 "or error messages indicate serious problems.\n",
389 "\n"; 923 "\n";
390 924
391 if (!-d "$path/treasures") { 925 if (!-d "$path/treasures") {
392 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 926 warn "FATAL: '$path' does not look like an arch directory ('treasures' directory is missing).\n";
393 exit 1 unless $FORCE; 927 exit 1 unless $FORCE;
394 } 928 }
395 929
930 print "starting file scan, arc, any processing...\n" if $VERBOSE;
931
932 my @a_arc = map +(async \&process_arc), 1..2;
933 my @a_any = map +(async \&process_any), 1..4;
934
396 find_files $path; 935 find_files $path;
397 IO::AIO::flush;
398 936
399 $_->join for ( 937 $c_arc->shutdown;
938 $c_any->shutdown;
939
940 $_->join for @a_arc; # need to parse all archetypes before png processing
941 print "finished arc processing...\n" if $VERBOSE;
942
943 # fill png queue
944 for (keys %FACEINFO) {
945 # we only expect source pngs to exist for non-derived
946 # faces, i.e. no split tiles (+x+x) and no face derivates
947 # (xxx:)
948 /^[^:]+\....$/
949 or next;
950
951 my $seen;
952
953 if (exists $PNG{"$_.32x32.png"}) {
954 push @c_png, ["$PNG{\"$_.32x32.png\"}/$_.32x32.png"];
955 $seen = 1;
956 }
957 if (exists $PNG{"$_.64x64.png"}) {
958 push @c_png, ["$PNG{\"$_.64x64.png\"}/$_.64x64.png"];
959 $seen = 1;
960 }
961
962 warn "ERROR: $_: face not found, expect problems.\n"
963 unless $seen;
964 }
965
966 print "starting png processing...\n" if $VERBOSE;
967
400 # four png crunchers work fine for my 2x smp machine 968 # eight png crunchers work fine for my 4x smp machine
401 (async \&process_png), (async \&process_png), (async \&process_png), (async \&process_png), 969 my @a_png = map +(async \&process_png), 1..8;
402 (async \&process_trs), (async \&process_trs),
403 (async \&process_arc), (async \&process_arc),
404 );
405 970
971 $_->join for @a_any;
972 print "finished any processing...\n" if $VERBOSE;
973
974 $_->join for @a_png;
975 print "finished png processing...\n" if $VERBOSE;
976
977 print "scanning done, processing results...\n" if $VERBOSE;
406 { 978 {
407 # remove path prefix from editor_folder 979 # remove path prefix from editor_folder
980 $_->{editor_folder} =~ /^\x00/
408 substr $_->{editor_folder}, 0, 1 + length $path, "" 981 and substr $_->{editor_folder}, 0, 2 + length $path, ""
409 for values %ARC; 982 for values %ARC;
410 983
984 print "resolving inheritance tree...\n" if $VERBOSE;
411 # resolve inherit 985 # resolve inherit
412 while () { 986 while () {
413 my $progress; 987 my $progress;
414 my $loop; 988 my $loop;
415 989
416 for my $o (values %ARC) { 990 for my $o (values %ARC) {
417 if (my $other = $o->{inherit}) { 991 for my $other (split /,/, $o->{inherit}) {
418 if (my $s = $ARC{$other}) { 992 if (my $s = $ARC{$other}) {
419 if ($s->{inherit}) { 993 if ($s->{inherit}) {
420 $loop = $s; 994 $loop = $s;
421 } else { 995 } else {
422 delete $o->{inherit}; 996 delete $o->{inherit};
… …
424 delete @s{qw(_name more name name_pl)}; 998 delete @s{qw(_name more name name_pl)};
425 %$o = ( %s, %$o ); 999 %$o = ( %s, %$o );
426 ++$progress; 1000 ++$progress;
427 } 1001 }
428 } else { 1002 } else {
429 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n"; 1003 warn "ERROR: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
430 delete $ARC{$o->{_name}}; 1004 delete $ARC{$o->{_name}};
431 } 1005 }
432 } 1006 }
433 } 1007 }
434 1008
… …
438 1012
439 last; 1013 last;
440 } 1014 }
441 } 1015 }
442 1016
1017 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
1018 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC;
1019
1020 # fix up archetypes without names, where the archanme doesn't work at all
1021 for (@ARC) {
1022 if (!exists $_->{name} and $_->{_name} =~ /_/) {
1023 for ($_->{name} = $_->{_name}) {
1024 s/(?:_\d+)+$//;
1025 s/_[nesw]+$//;
1026 y/_/ /;
1027 }
1028 }
1029 }
1030
1031 #print "generating plurals...\n" if $VERBOSE;
1032 #generate_plurals;
1033
1034 printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
443 open my $fh, ">:utf8", "$DATADIR/archetypes~" 1035 open my $fh, ">:utf8", "$DATADIR/archetypes~"
444 or die "$DATADIR/archetypes~: $!"; 1036 or die "$DATADIR/archetypes~: $!";
445 print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC]; 1037 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
446 } 1038 }
447 1039
448 { 1040 {
1041 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
449 open my $fh, ">:utf8", "$DATADIR/treasures~" 1042 open my $fh, ">:utf8", "$DATADIR/treasures~"
450 or die "$DATADIR/treasures~: $!"; 1043 or die "$DATADIR/treasures~: $!";
451 print $fh $TRS; 1044 print $fh $TRS;
452 } 1045 }
453 1046
454 { 1047 {
455 while (my ($k, $v) = each %FACEINFO) { 1048 print "processing facedata...\n" if $VERBOSE;
456 length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
457 length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
458
459 length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";
460 #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
461
462 $v->{chksum32} = Digest::MD5::md5 $v->{data32};
463 $v->{chksum64} = Digest::MD5::md5 $v->{data64};
464 } 1049
1050 for my $k (sort keys %FACEINFO) {
1051 my $v = $FACEINFO{$k};
465 1052
1053 length $v->{data32} or warn "ERROR: face '$k' has no png32 - this will not work.\n";
1054 length $v->{data64} or warn "ERROR: face '$k' has no png64 - this will not work.\n";
1055
1056 make_hash $k, $v->{data32}, $v->{hash32};
1057 make_hash $k, $v->{data64}, $v->{hash64};
1058
1059 #length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
1060 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
1061
1062 $v->{glyph} // warn "ERROR: face '$k' has no glyph - missing faceinfo entry?\n";
1063 $v->{visibility} // warn "ERROR: face '$k' has no visibility info - missing faceinfo entry?\n";
1064 $v->{magicmap} // warn "ERROR: face '$k' has no foreground colour - missing faceinfo entry?\n";
1065
1066 if (0 && $v->{w} == 1 && $v->{h} == 1) { # texture catalogs
1067 my $id = @TC;
1068 my $n = @{ $TC[-1] };
1069 my $x = $n % TC_W;
1070 my $y = int $n / TC_W;
1071
1072 push @{ $TC[-1] }, [$v, $x, $y];
1073
1074 $v->{tc} = [$id, $x, $y];
1075
1076 push @TC, [] if $n == TC_W * TC_H - 1; # start new texture if full
1077 }
1078
1079 delete @$v{qw(w h arc stem derive)}; # not used by the server
1080 }
1081
1082if (0) { #d# texture catalogs
1083 print "creating texture catalogs...\n" if $VERBOSE;
1084
1085 for my $id (0 .. $#TC) {
1086 my $tc = $TC[$id];
1087
1088 my $cmd = "$CONVERT -depth 8 -size " . (TC_W * 64) . "x" . (TC_H * 64) . " xc:transparent";
1089 my $idx = "a";
1090
1091 for (@$tc) {
1092 my $path = "$TMPDIR/tc" . $idx++;
1093
1094 open my $fh, ">:perlio", $path
1095 or die "$path: $!";
1096 syswrite $fh, $_->[0]{data64};
1097
1098 my $x = $_->[1] * 64;
1099 my $y = $_->[2] * 64;
1100
1101 $cmd .= " png:\Q$path\E -geometry +$x+$y -composite";
1102 }
1103
1104 system "$cmd png:\Q$TMPDIR/tc$id\E";
1105 optipng "$TMPDIR/tc$id";
1106 }
1107}
1108
1109 print "processing resources...\n" if $VERBOSE;
1110 my $enc = JSON::XS->new->utf8->canonical->relaxed;
1111 while (my ($k, $v) = each %RESOURCE) {
1112 if ($v->{meta} && $v->{meta}{datadir}) {
1113 delete $RESOURCE{$k};
1114
1115 $k =~ s/^res\/// or die "$k: datadir files must be in res/";
1116
1117 printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
1118 open my $fh, ">:raw", "$DATADIR/$k~"
1119 or die "$DATADIR/$k~: $!";
1120 syswrite $fh, $v->{data};
1121 push @COMMIT, $k;
1122
1123 } else {
1124 if ($v->{type} & 1) {
1125 # prepend meta info
1126
1127 my $meta = $enc->encode ({
1128 name => $k,
1129 %{ $v->{meta} || {} },
1130 });
1131
1132 $v->{data} = pack "(w/a*)*", $meta, $v->{data};
1133 }
1134
1135 make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
1136 }
1137 }
1138
1139 printf "writing facedata...\n" if $VERBOSE;
1140
1141 {
466 open my $fh, ">:perlio", "$DATADIR/facedata~" 1142 open my $fh, ">:perlio", "$DATADIR/facedata~"
467 or die "$DATADIR/facedata~: $!"; 1143 or die "$DATADIR/facedata~: $!";
468 1144
1145 print $fh "FACEDATA";
1146 my $fofs = 8;
1147
1148 my $put = sub {
1149 my $len = length $_[0];
1150 my $ofs = $fofs;
1151
1152 print $fh $_[0];
1153 $fofs += $len;
1154
1155 ($len, $ofs)
1156 };
1157
1158 for (values %FACEINFO) {
1159 ($_->{size32}, $_->{fofs32}) = $put->(delete $_->{data32});
1160 ($_->{size64}, $_->{fofs64}) = $put->(delete $_->{data64});
1161 }
1162
1163 for (values %RESOURCE) {
1164 ($_->{size}, $_->{fofs}) = $put->(delete $_->{data});
1165 }
1166
1167 close $fh;
1168 }
1169
1170 printf "writing faceinfo (%d faces, %d anims, %d resources)...\n",
1171 scalar keys %FACEINFO,
1172 scalar keys %ANIMINFO,
1173 scalar keys %RESOURCE
1174 if $VERBOSE;
1175
1176 open my $fh, ">:perlio", "$DATADIR/faceinfo~"
1177 or die "$DATADIR/faceinfo~: $!";
1178
469 print $fh freeze { 1179 print $fh nfreeze {
470 version => 2, 1180 version => 2,
471 faceinfo => \%FACEINFO, 1181 faceinfo => \%FACEINFO,
472 animinfo => \%ANIMINFO, 1182 animinfo => \%ANIMINFO,
1183 resource => \%RESOURCE,
473 }; 1184 };
474 } 1185 }
475 1186
1187 print "committing files...\n" if $VERBOSE;
1188
476 for (qw(archetypes facedata treasures)) { 1189 for (qw(archetypes faceinfo facedata treasures), @COMMIT) {
477 chmod 0644, "$DATADIR/$_~"; 1190 chmod 0644, "$DATADIR/$_~";
478 rename "$DATADIR/$_~", "$DATADIR/$_" 1191 rename "$DATADIR/$_~", "$DATADIR/$_"
479 or die "$DATADIR/$_: $!"; 1192 or die "$DATADIR/$_: $!";
480 } 1193 }
481 1194

Diff Legend

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