| 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"; |
| … | |
… | |
| 455 | my $fi = $FACEINFO{$face} ||= { }; |
488 | my $fi = $FACEINFO{$face} ||= { }; |
| 456 | $fi->{visibility} = $visibility * 1; |
489 | $fi->{visibility} = $visibility * 1; |
| 457 | $fi->{magicmap} = $fgi; # foreground colour becomes magicmap |
490 | $fi->{magicmap} = $fgi; # foreground colour becomes magicmap |
| 458 | |
491 | |
| 459 | $glyph .= " " if 2 > length $glyph; # TODO kanji |
492 | $glyph .= " " if 2 > length $glyph; # TODO kanji |
|
|
493 | die "glyph $face too long" if 2 < length $glyph; |
| 460 | |
494 | |
| 461 | $fi->{glyph} = ""; |
495 | $fi->{glyph} = ""; |
| 462 | for (split //, $glyph, -1) { |
496 | for (split //, $glyph) { |
| 463 | utf8::encode $_; |
497 | utf8::encode $_; |
| 464 | $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_; |
498 | $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_; |
| 465 | } |
499 | } |
| 466 | } |
500 | } |
| 467 | } |
501 | } |
| … | |
… | |
| 578 | } |
612 | } |
| 579 | |
613 | |
| 580 | $FILECACHE{$_[0]} |
614 | $FILECACHE{$_[0]} |
| 581 | } |
615 | } |
| 582 | |
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 | next if /^\s*#/; |
|
|
632 | |
|
|
633 | /^([0-9a-fA-F]{3,6})\s*(.*?)\s*$/ |
|
|
634 | or die "unparseable palette entry for $base.plt: $_"; |
|
|
635 | |
|
|
636 | my ($rgb, $name) = ($1, $2); |
|
|
637 | |
|
|
638 | $rgb =~ s/^(.)(.)(.)$/$1$1$2$2$3$3/; |
|
|
639 | |
|
|
640 | $map{pack "H*", $rgb} = chr @plt; |
|
|
641 | push @plt, $name; |
|
|
642 | } |
|
|
643 | |
|
|
644 | make_file ["$base.plt", "$base.png"], "$base.tbl~", sub { |
|
|
645 | warn "building $base\n" if $VERBOSE >= 3; |
|
|
646 | |
|
|
647 | fork_exec { |
|
|
648 | open my $png, "-|", $CONVERT, qw(-depth 8 --), "$base.png", "rgb:" |
|
|
649 | or die "$base.png: $!"; |
|
|
650 | |
|
|
651 | local $/; |
|
|
652 | $png = <$png>; |
|
|
653 | |
|
|
654 | $w * $h * 3 == length $png |
|
|
655 | or die "$base.png: failed to read enough data from file\n"; |
|
|
656 | |
|
|
657 | $png =~ s/(...)/$map{$1}/ge; |
|
|
658 | |
|
|
659 | $w * $h == length $png |
|
|
660 | or die "$base.png: failed to map all data - wrong palette?\n"; |
|
|
661 | |
|
|
662 | { |
|
|
663 | open my $fh, ">:raw", "$base.tbl~~" |
|
|
664 | or die "$base.tbl~~: $!"; |
|
|
665 | syswrite $fh, $png; |
|
|
666 | } |
|
|
667 | |
|
|
668 | rename "$base.tbl~~", "$base.tbl~"; |
|
|
669 | }; |
|
|
670 | }; |
|
|
671 | |
|
|
672 | 0 <= aio_load "$base.tbl~", my $tbl |
|
|
673 | or die "$base.tbl~: $!"; |
|
|
674 | |
|
|
675 | IO::AIO::aio_unlink "$base.tbl~" unless $CACHE; |
|
|
676 | |
|
|
677 | Compress::LZF::compress nfreeze { |
|
|
678 | w => $w, |
|
|
679 | h => $h, |
|
|
680 | plt => \@plt, |
|
|
681 | tbl => $tbl, |
|
|
682 | } |
|
|
683 | } |
|
|
684 | |
| 583 | sub process_res { |
685 | sub process_res { |
| 584 | my ($dir, $file, $type) = @_; |
686 | my ($dir, $file, $type) = @_; |
| 585 | |
687 | |
| 586 | my $data; |
|
|
| 587 | aio_load "$dir/$file", $data; |
688 | 0 <= aio_load "$dir/$file", my $data |
|
|
689 | or die "$dir/$file: $!"; |
| 588 | |
690 | |
| 589 | my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) }; |
691 | my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) }; |
| 590 | |
692 | |
| 591 | utf8::decode $dir; |
693 | utf8::decode $dir; |
| 592 | utf8::decode $file; |
694 | utf8::decode $file; |
| … | |
… | |
| 619 | } |
721 | } |
| 620 | |
722 | |
| 621 | $file =~ s/\.res$//; |
723 | $file =~ s/\.res$//; |
| 622 | $file =~ s/\.(ogg|wav|jpg|png)$//; |
724 | $file =~ s/\.(ogg|wav|jpg|png)$//; |
| 623 | |
725 | |
| 624 | substr $dir, 0, 1 + length $PATH, ""; |
726 | if ($file =~ s/\.plt$//) { |
| 625 | |
727 | $data = process_plt "$dir/$file", $data; |
| 626 | if (my $filter = $meta->{cfutil_filter}) { |
728 | } elsif (my $filter = $meta->{cfutil_filter}) { |
| 627 | if ($filter eq "yaml2json") { |
729 | if ($filter eq "yaml2json") { |
| 628 | $data = JSON::XS::encode_json YAML::XS::Load $data; |
730 | $data = JSON::XS::encode_json YAML::XS::Load $data; |
| 629 | } elsif ($filter eq "json2json") { |
731 | } elsif ($filter eq "json2json") { |
| 630 | $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); |
732 | $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); |
| 631 | } elsif ($filter eq "perl2json") { |
733 | } elsif ($filter eq "perl2json") { |
| … | |
… | |
| 633 | $data = JSON::XS::encode_json $data; |
735 | $data = JSON::XS::encode_json $data; |
| 634 | } else { |
736 | } else { |
| 635 | warn "$dir/$file: unknown filter $filter, skipping\n"; |
737 | warn "$dir/$file: unknown filter $filter, skipping\n"; |
| 636 | } |
738 | } |
| 637 | } |
739 | } |
|
|
740 | |
|
|
741 | substr $dir, 0, 1 + length $PATH, ""; |
| 638 | |
742 | |
| 639 | $RESOURCE{"$dir/$file"} = { |
743 | $RESOURCE{"$dir/$file"} = { |
| 640 | type => (exists $meta->{type} ? delete $meta->{type} : $type), |
744 | type => (exists $meta->{type} ? delete $meta->{type} : $type), |
| 641 | data => $data, |
745 | data => $data, |
| 642 | %$meta ? (meta => $meta) : (), |
746 | %$meta ? (meta => $meta) : (), |
| … | |
… | |
| 910 | version => 2, |
1014 | version => 2, |
| 911 | faceinfo => \%FACEINFO, |
1015 | faceinfo => \%FACEINFO, |
| 912 | animinfo => \%ANIMINFO, |
1016 | animinfo => \%ANIMINFO, |
| 913 | resource => \%RESOURCE, |
1017 | resource => \%RESOURCE, |
| 914 | }; |
1018 | }; |
| 915 | |
|
|
| 916 | } |
1019 | } |
| 917 | |
1020 | |
| 918 | print "committing files...\n" if $VERBOSE; |
1021 | print "committing files...\n" if $VERBOSE; |
| 919 | |
1022 | |
| 920 | for (qw(archetypes facedata treasures), @COMMIT) { |
1023 | for (qw(archetypes facedata treasures), @COMMIT) { |
