1 | #!@PERL@ |
1 | #!@PERL@ |
2 | |
2 | |
3 | # |
3 | # |
4 | # This file is part of Deliantra, the Roguelike Realtime MMORPG. |
4 | # This file is part of Deliantra, the Roguelike Realtime MMORPG. |
5 | # |
5 | # |
6 | # Copyright (©) 2007,2008,2009 Marc Alexander Lehmann / Robin Redeker / the Deliantra team |
6 | # Copyright (©) 2007,2008,2009,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team |
7 | # |
7 | # |
8 | # Deliantra is free software: you can redistribute it and/or modify it under |
8 | # Deliantra is free software: you can redistribute it and/or modify it under |
9 | # the terms of the Affero GNU General Public License as published by the |
9 | # the terms of the Affero GNU General Public License as published by the |
10 | # Free Software Foundation, either version 3 of the License, or (at your |
10 | # Free Software Foundation, either version 3 of the License, or (at your |
11 | # option) any later version. |
11 | # option) any later version. |
… | |
… | |
28 | my $exec_prefix = "@exec_prefix@"; |
28 | my $exec_prefix = "@exec_prefix@"; |
29 | my $datarootdir = "@datarootdir@"; |
29 | my $datarootdir = "@datarootdir@"; |
30 | my $DATADIR = "@datadir@/@PACKAGE@"; |
30 | my $DATADIR = "@datadir@/@PACKAGE@"; |
31 | |
31 | |
32 | my $CONVERT = "@CONVERT@"; |
32 | my $CONVERT = "@CONVERT@"; |
33 | #my $IDENTIFY = "@IDENTIFY@"; |
33 | my $IDENTIFY = "@IDENTIFY@"; |
34 | my $OPTIPNG = "@OPTIPNG@"; |
34 | my $OPTIPNG = "@OPTIPNG@"; |
35 | my $RSYNC = "@RSYNC@"; |
35 | my $RSYNC = "@RSYNC@"; |
36 | my $PNGNQ = "@PNGNQ@"; |
36 | my $PNGNQ = "@PNGNQ@"; |
37 | |
37 | |
38 | use Getopt::Long; |
38 | use Getopt::Long; |
39 | use File::Temp; |
39 | use File::Temp; |
40 | use POSIX (); |
40 | use POSIX (); |
41 | use Carp; |
41 | use Carp; |
42 | |
42 | |
43 | use Coro::EV; |
|
|
44 | use AnyEvent; |
|
|
45 | use YAML::XS (); |
43 | use YAML::XS (); |
|
|
44 | use Digest::MD5 (); |
|
|
45 | use Storable (); |
46 | use JSON::XS (); |
46 | use JSON::XS (); |
47 | use IO::AIO (); |
47 | use IO::AIO (); |
48 | use Digest::MD5 (); |
48 | use Compress::LZF (); |
49 | |
49 | |
|
|
50 | use AnyEvent; |
50 | use Coro 5.12; |
51 | use Coro 5.12; |
|
|
52 | use Coro::EV; |
51 | use Coro::AIO; |
53 | use Coro::AIO; |
52 | use Coro::Util; |
54 | use Coro::Util; |
53 | use Coro::Channel; |
55 | use Coro::Channel; |
|
|
56 | use Coro::AnyEvent; |
54 | use Coro::Storable; $Storable::canonical = 1; |
57 | use Coro::Storable; $Storable::canonical = 1; |
55 | |
58 | |
56 | use Deliantra; |
59 | use Deliantra; |
57 | |
60 | |
58 | $SIG{QUIT} = sub { Carp::cluck "QUIT" }; |
61 | $SIG{QUIT} = sub { Carp::cluck "QUIT" }; |
… | |
… | |
132 | } |
135 | } |
133 | |
136 | |
134 | mkdir $TMPDIR, 0700 |
137 | mkdir $TMPDIR, 0700 |
135 | or die "$TMPDIR: $!"; |
138 | or die "$TMPDIR: $!"; |
136 | |
139 | |
137 | sub fork_sub(&) { |
140 | sub fork_exec(&) { |
138 | my ($cb) = @_; |
141 | my ($cb) = @_; |
139 | |
142 | |
140 | if (my $pid = fork) { |
143 | if (my $pid = fork) { |
141 | my $current = $Coro::current; |
144 | my $current = $Coro::current; |
142 | my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); |
145 | my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); |
… | |
… | |
147 | warn $@; |
150 | warn $@; |
148 | POSIX::_exit 1; |
151 | POSIX::_exit 1; |
149 | } |
152 | } |
150 | } |
153 | } |
151 | |
154 | |
|
|
155 | sub imgsize($) { |
|
|
156 | open my $fh, "-|", $IDENTIFY, qw(-ping -format %w,%h --), $_[0] |
|
|
157 | or die "$IDENTIFY: $!"; |
|
|
158 | |
|
|
159 | Coro::AnyEvent::readable $fh; |
|
|
160 | |
|
|
161 | my ($w, $h) = split /,/, <$fh>; |
|
|
162 | |
|
|
163 | ($w+0, $h+0) |
|
|
164 | } |
|
|
165 | |
|
|
166 | # make $dst from $src, if not uptodate, by calling $how |
|
|
167 | sub make_file($$$) { |
|
|
168 | my ($src, $dst, $how) = @_; |
|
|
169 | |
|
|
170 | my $t = (aio_stat $dst) ? -1 : (stat _)[9]; |
|
|
171 | |
|
|
172 | for (ref $src ? @$src : $src) { |
|
|
173 | aio_stat $_ |
|
|
174 | and die "$_: $!"; |
|
|
175 | |
|
|
176 | if ((stat _)[9] > $t) { |
|
|
177 | # outdated, redo |
|
|
178 | $how->(); |
|
|
179 | last; |
|
|
180 | } |
|
|
181 | } |
|
|
182 | } |
|
|
183 | |
152 | sub inst_maps($) { |
184 | sub inst_maps($) { |
153 | my (undef, $path) = @_; |
185 | my (undef, $path) = @_; |
154 | |
186 | |
155 | print "\nInstalling '$path' to '$DATADIR/maps'\n\n"; |
187 | print "\nInstalling '$path' to '$DATADIR/maps'\n\n"; |
156 | |
188 | |
… | |
… | |
248 | unless ($path =~ /~$/) { |
280 | unless ($path =~ /~$/) { |
249 | # possibly enlarge |
281 | # possibly enlarge |
250 | if (0 > aio_stat "$stem.64x64.png") { |
282 | if (0 > aio_stat "$stem.64x64.png") { |
251 | my $other = "$stem.64x64.png~"; |
283 | my $other = "$stem.64x64.png~"; |
252 | |
284 | |
253 | if (0 > aio_lstat $other or (-M _) > (-M $path)) { |
285 | make_file $path, $other, sub { |
254 | fork_sub { |
286 | fork_exec { |
255 | my $CROP; |
287 | my $CROP; |
256 | my $SRC = "png:\Q$path\E"; |
288 | my $SRC = "png:\Q$path\E"; |
257 | |
289 | |
258 | my $is_floor = $arc->{is_floor}; |
290 | my $is_floor = $arc->{is_floor}; |
259 | my $is_wall = 0; |
291 | my $is_wall = 0; |
… | |
… | |
317 | and die "convert/cfhq2xa pipeline error: status $? ($!)"; |
349 | and die "convert/cfhq2xa pipeline error: status $? ($!)"; |
318 | system $OPTIPNG, "-i0", "-q", "$other~"; |
350 | system $OPTIPNG, "-i0", "-q", "$other~"; |
319 | die "$other~ has zero size, aborting." unless -s "$other~"; |
351 | die "$other~ has zero size, aborting." unless -s "$other~"; |
320 | rename "$other~", $other; |
352 | rename "$other~", $other; |
321 | }; |
353 | }; |
322 | } |
354 | }; |
323 | |
355 | |
324 | push @c_png, [$other, !$CACHE]; |
356 | push @c_png, [$other, !$CACHE]; |
325 | } |
357 | } |
326 | |
358 | |
327 | # possibly scale down |
359 | # possibly scale down |
328 | if (0 > aio_stat "$stem.32x32.png") { |
360 | if (0 > aio_stat "$stem.32x32.png") { |
329 | my $other = "$stem.32x32.png~"; |
361 | my $other = "$stem.32x32.png~"; |
330 | |
362 | |
331 | if (0 > aio_lstat $other or (-M _) > (-M $path)) { |
363 | make_file $path, $other, sub { |
332 | fork_sub { |
364 | fork_exec { |
333 | system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~"; |
365 | system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~"; |
334 | system $OPTIPNG, "-i0", "-q", "$other~"; |
366 | system $OPTIPNG, "-i0", "-q", "$other~"; |
335 | |
367 | |
336 | # reduce smoothfaces >10000 bytes |
368 | # reduce smoothfaces >10000 bytes |
337 | # obsolete, no longer required |
369 | # obsolete, no longer required |
… | |
… | |
352 | } |
384 | } |
353 | |
385 | |
354 | die "$other~ has zero size, aborting." unless -s "$other~"; |
386 | die "$other~ has zero size, aborting." unless -s "$other~"; |
355 | rename "$other~", $other; |
387 | rename "$other~", $other; |
356 | }; |
388 | }; |
357 | } |
389 | }; |
358 | |
390 | |
359 | #warn "scaled down $path to $other\n";#d# |
391 | #warn "scaled down $path to $other\n";#d# |
360 | push @c_png, [$other, !$CACHE]; |
392 | push @c_png, [$other, !$CACHE]; |
361 | } |
393 | } |
362 | } |
394 | } |
… | |
… | |
376 | } |
408 | } |
377 | |
409 | |
378 | my $mtime = (lstat $path)[9]; |
410 | my $mtime = (lstat $path)[9]; |
379 | my @todo = grep { $_->[3] <= $mtime } @tile; |
411 | my @todo = grep { $_->[3] <= $mtime } @tile; |
380 | if (@todo) { |
412 | if (@todo) { |
381 | fork_sub { |
413 | fork_exec { |
382 | open my $convert, "|-", $CONVERT, |
414 | open my $convert, "|-", $CONVERT, |
383 | "png:-", |
415 | "png:-", |
384 | (map { |
416 | (map { |
385 | ( |
417 | ( |
386 | "(", |
418 | "(", |
… | |
… | |
437 | return; |
469 | return; |
438 | } |
470 | } |
439 | |
471 | |
440 | for (split /\n/, $data) { |
472 | for (split /\n/, $data) { |
441 | chomp; |
473 | chomp; |
442 | my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/; |
474 | my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5; |
443 | # bg not used except for text clients |
475 | # bg not used except for text clients |
444 | |
476 | |
445 | utf8::decode $glyph; |
477 | utf8::decode $glyph; |
446 | $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag |
478 | $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag |
|
|
479 | $glyph =~ s/^"(.+)"$/$1/; # allow for ""-style quoting |
447 | |
480 | |
448 | $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet |
481 | $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet |
449 | |
482 | |
450 | (my $fgi = $COLOR{$fg}) |
483 | (my $fgi = $COLOR{$fg}) |
451 | // warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n"; |
484 | // warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n"; |
… | |
… | |
579 | } |
612 | } |
580 | |
613 | |
581 | $FILECACHE{$_[0]} |
614 | $FILECACHE{$_[0]} |
582 | } |
615 | } |
583 | |
616 | |
|
|
617 | # convert an image and a palette to some indexed 2d-matrix structure |
|
|
618 | sub process_plt { |
|
|
619 | my ($base, $plt) = @_; |
|
|
620 | |
|
|
621 | my ($w, $h) = imgsize "$base.png"; |
|
|
622 | |
|
|
623 | $w * $h |
|
|
624 | or die "$base.png: unable to identify correct size\n"; |
|
|
625 | |
|
|
626 | my @plt; |
|
|
627 | my %map; |
|
|
628 | |
|
|
629 | for (split /\n/, $plt) { |
|
|
630 | next unless /\S/; |
|
|
631 | |
|
|
632 | /^([0-9a-fA-F]{3,6})\s*(.*?)\s*$/ |
|
|
633 | or die "unparseable palette entry for $base.plt: $_"; |
|
|
634 | |
|
|
635 | my ($rgb, $name) = ($1, $2); |
|
|
636 | |
|
|
637 | $rgb =~ s/^(.)(.)(.)$/$1$1$2$2$3$3/; |
|
|
638 | |
|
|
639 | $map{pack "H*", $rgb} = chr @plt; |
|
|
640 | push @plt, $name; |
|
|
641 | } |
|
|
642 | |
|
|
643 | make_file ["$base.plt", "$base.png"], "$base.tbl~", sub { |
|
|
644 | warn "building $base\n" if $VERBOSE >= 3; |
|
|
645 | |
|
|
646 | fork_exec { |
|
|
647 | open my $png, "-|", $CONVERT, qw(-depth 8 --), "$base.png", "rgb:" |
|
|
648 | or die "$base.png: $!"; |
|
|
649 | |
|
|
650 | local $/; |
|
|
651 | $png = <$png>; |
|
|
652 | |
|
|
653 | $w * $h * 3 == length $png |
|
|
654 | or die "$base.png: failed to read enough data from file\n"; |
|
|
655 | |
|
|
656 | $png =~ s/(...)/$map{$1}/ge; |
|
|
657 | |
|
|
658 | $w * $h == length $png |
|
|
659 | or die "$base.png: failed to map all data - wrong palette?\n"; |
|
|
660 | |
|
|
661 | { |
|
|
662 | open my $fh, ">:raw", "$base.tbl~~" |
|
|
663 | or die "$base.tbl~~: $!"; |
|
|
664 | syswrite $fh, $png; |
|
|
665 | } |
|
|
666 | |
|
|
667 | rename "$base.tbl~~", "$base.tbl~"; |
|
|
668 | }; |
|
|
669 | }; |
|
|
670 | |
|
|
671 | 0 <= aio_load "$base.tbl~", my $tbl |
|
|
672 | or die "$base.tbl~: $!"; |
|
|
673 | |
|
|
674 | IO::AIO::aio_unlink "$base.tbl~" unless $CACHE; |
|
|
675 | |
|
|
676 | Compress::LZF::compress nfreeze { |
|
|
677 | w => $w, |
|
|
678 | h => $h, |
|
|
679 | plt => \@plt, |
|
|
680 | tbl => $tbl, |
|
|
681 | } |
|
|
682 | } |
|
|
683 | |
584 | sub process_res { |
684 | sub process_res { |
585 | my ($dir, $file, $type) = @_; |
685 | my ($dir, $file, $type) = @_; |
586 | |
686 | |
587 | my $data; |
|
|
588 | aio_load "$dir/$file", $data; |
687 | 0 <= aio_load "$dir/$file", my $data |
|
|
688 | or die "$dir/$file: $!"; |
589 | |
689 | |
590 | my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) }; |
690 | my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) }; |
591 | |
691 | |
592 | utf8::decode $dir; |
692 | utf8::decode $dir; |
593 | utf8::decode $file; |
693 | utf8::decode $file; |
… | |
… | |
620 | } |
720 | } |
621 | |
721 | |
622 | $file =~ s/\.res$//; |
722 | $file =~ s/\.res$//; |
623 | $file =~ s/\.(ogg|wav|jpg|png)$//; |
723 | $file =~ s/\.(ogg|wav|jpg|png)$//; |
624 | |
724 | |
625 | substr $dir, 0, 1 + length $PATH, ""; |
725 | if ($file =~ s/\.plt$//) { |
626 | |
726 | $data = process_plt "$dir/$file", $data; |
627 | if (my $filter = $meta->{cfutil_filter}) { |
727 | } elsif (my $filter = $meta->{cfutil_filter}) { |
628 | if ($filter eq "yaml2json") { |
728 | if ($filter eq "yaml2json") { |
629 | $data = JSON::XS::encode_json YAML::XS::Load $data; |
729 | $data = JSON::XS::encode_json YAML::XS::Load $data; |
630 | } elsif ($filter eq "json2json") { |
730 | } elsif ($filter eq "json2json") { |
631 | $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); |
731 | $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); |
632 | } elsif ($filter eq "perl2json") { |
732 | } elsif ($filter eq "perl2json") { |
… | |
… | |
634 | $data = JSON::XS::encode_json $data; |
734 | $data = JSON::XS::encode_json $data; |
635 | } else { |
735 | } else { |
636 | warn "$dir/$file: unknown filter $filter, skipping\n"; |
736 | warn "$dir/$file: unknown filter $filter, skipping\n"; |
637 | } |
737 | } |
638 | } |
738 | } |
|
|
739 | |
|
|
740 | substr $dir, 0, 1 + length $PATH, ""; |
639 | |
741 | |
640 | $RESOURCE{"$dir/$file"} = { |
742 | $RESOURCE{"$dir/$file"} = { |
641 | type => (exists $meta->{type} ? delete $meta->{type} : $type), |
743 | type => (exists $meta->{type} ? delete $meta->{type} : $type), |
642 | data => $data, |
744 | data => $data, |
643 | %$meta ? (meta => $meta) : (), |
745 | %$meta ? (meta => $meta) : (), |
… | |
… | |
911 | version => 2, |
1013 | version => 2, |
912 | faceinfo => \%FACEINFO, |
1014 | faceinfo => \%FACEINFO, |
913 | animinfo => \%ANIMINFO, |
1015 | animinfo => \%ANIMINFO, |
914 | resource => \%RESOURCE, |
1016 | resource => \%RESOURCE, |
915 | }; |
1017 | }; |
916 | |
|
|
917 | } |
1018 | } |
918 | |
1019 | |
919 | print "committing files...\n" if $VERBOSE; |
1020 | print "committing files...\n" if $VERBOSE; |
920 | |
1021 | |
921 | for (qw(archetypes facedata treasures), @COMMIT) { |
1022 | for (qw(archetypes facedata treasures), @COMMIT) { |