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.109 by root, Wed Oct 20 15:55:07 2010 UTC vs.
Revision 1.114 by root, Sat May 14 17:13:38 2011 UTC

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,2010 Marc Alexander Lehmann / Robin Redeker / the Deliantra team 6# Copyright (©) 2007,2008,2009,2010,2011 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.
… …
28my $exec_prefix = "@exec_prefix@"; 28my $exec_prefix = "@exec_prefix@";
29my $datarootdir = "@datarootdir@"; 29my $datarootdir = "@datarootdir@";
30my $DATADIR = "@datadir@/@PACKAGE@"; 30my $DATADIR = "@datadir@/@PACKAGE@";
31 31
32my $CONVERT = "@CONVERT@"; 32my $CONVERT = "@CONVERT@";
33#my $IDENTIFY = "@IDENTIFY@"; 33my $IDENTIFY = "@IDENTIFY@";
34my $OPTIPNG = "@OPTIPNG@"; 34my $OPTIPNG = "@OPTIPNG@";
35my $RSYNC = "@RSYNC@"; 35my $RSYNC = "@RSYNC@";
36my $PNGNQ = "@PNGNQ@"; 36my $PNGNQ = "@PNGNQ@";
37 37
38use Getopt::Long; 38use Getopt::Long;
39use File::Temp; 39use File::Temp;
40use POSIX (); 40use POSIX ();
41use Carp; 41use Carp;
42 42
43use Coro::EV;
44use AnyEvent;
45use YAML::XS (); 43use YAML::XS ();
44use Digest::MD5 ();
45use Storable ();
46use JSON::XS (); 46use JSON::XS ();
47use IO::AIO (); 47use IO::AIO ();
48use Digest::MD5 (); 48use Compress::LZF ();
49 49
50use AnyEvent;
50use Coro 5.12; 51use Coro 5.12;
52use Coro::EV;
51use Coro::AIO; 53use Coro::AIO;
52use Coro::Util; 54use Coro::Util;
53use Coro::Channel; 55use Coro::Channel;
56use Coro::AnyEvent;
54use Coro::Storable; $Storable::canonical = 1; 57use Coro::Storable; $Storable::canonical = 1;
55 58
56use Deliantra; 59use Deliantra;
57 60
58$SIG{QUIT} = sub { Carp::cluck "QUIT" }; 61$SIG{QUIT} = sub { Carp::cluck "QUIT" };
… …
113 116
114# here we could try to avoid collisions and reduce chksum size further 117# here we could try to avoid collisions and reduce chksum size further
115sub make_hash($\$\$;$) { 118sub make_hash($\$\$;$) {
116 my ($id, $dataref, $hashref, $clen) = @_; 119 my ($id, $dataref, $hashref, $clen) = @_;
117 120
118 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 4; 121 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 5;
119 122
120 if (exists $hash{$hash}) { 123 if (exists $hash{$hash}) {
121 # hash collision, but some files are simply identical 124 # hash collision, but some files are simply identical
122 if (${$hash{$hash}[1]} ne $$dataref) { 125 if (${$hash{$hash}[1]} ne $$dataref) {
123 warn "hash collision $hash{$hash}[0] vs. $id\n"; 126 warn "hash collision $hash{$hash}[0] vs. $id\n";
… …
129 $hash{$hash} = [$id, $dataref, $hashref]; 132 $hash{$hash} = [$id, $dataref, $hashref];
130 133
131 $$hashref = $hash; 134 $$hashref = $hash;
132} 135}
133 136
137sub optipng($) {
138 system $OPTIPNG, "-i0", "-q", $_[0];
139 die "$_[0] has zero size, aborting." unless -s $_[0];
140}
141
134mkdir $TMPDIR, 0700 142mkdir $TMPDIR, 0700
135 or die "$TMPDIR: $!"; 143 or die "$TMPDIR: $!";
136 144
137sub fork_sub(&) { 145sub fork_exec(&) {
138 my ($cb) = @_; 146 my ($cb) = @_;
139 147
140 if (my $pid = fork) { 148 if (my $pid = fork) {
141 my $current = $Coro::current; 149 my $current = $Coro::current;
142 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); 150 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
… …
147 warn $@; 155 warn $@;
148 POSIX::_exit 1; 156 POSIX::_exit 1;
149 } 157 }
150} 158}
151 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
152sub inst_maps($) { 189sub inst_maps($) {
153 my (undef, $path) = @_; 190 my (undef, $path) = @_;
154 191
155 print "\nInstalling '$path' to '$DATADIR/maps'\n\n"; 192 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
156 193
… …
248 unless ($path =~ /~$/) { 285 unless ($path =~ /~$/) {
249 # possibly enlarge 286 # possibly enlarge
250 if (0 > aio_stat "$stem.64x64.png") { 287 if (0 > aio_stat "$stem.64x64.png") {
251 my $other = "$stem.64x64.png~"; 288 my $other = "$stem.64x64.png~";
252 289
253 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 290 make_file $path, $other, sub {
254 fork_sub { 291 fork_exec {
255 my $CROP; 292 my $CROP;
256 my $SRC = "png:\Q$path\E"; 293 my $SRC = "png:\Q$path\E";
257 294
258 my $is_floor = $arc->{is_floor}; 295 my $is_floor = $arc->{is_floor};
259 my $is_wall = 0; 296 my $is_wall = 0;
… …
313 350
314 system "convert -depth 8 $SRC rgba:-" 351 system "convert -depth 8 $SRC rgba:-"
315 . "| $exec_prefix/bin/cfhq2xa $w $h 0" 352 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
316 . "| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $CROP $QUANTIZE -quality 00 png32:\Q$other\E~" 353 . "| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $CROP $QUANTIZE -quality 00 png32:\Q$other\E~"
317 and die "convert/cfhq2xa pipeline error: status $? ($!)"; 354 and die "convert/cfhq2xa pipeline error: status $? ($!)";
318 system $OPTIPNG, "-i0", "-q", "$other~"; 355 optipng "$other~";
319 die "$other~ has zero size, aborting." unless -s "$other~";
320 rename "$other~", $other; 356 rename "$other~", $other;
321 }; 357 };
322 } 358 };
323 359
324 push @c_png, [$other, !$CACHE]; 360 push @c_png, [$other, !$CACHE];
325 } 361 }
326 362
327 # possibly scale down 363 # possibly scale down
328 if (0 > aio_stat "$stem.32x32.png") { 364 if (0 > aio_stat "$stem.32x32.png") {
329 my $other = "$stem.32x32.png~"; 365 my $other = "$stem.32x32.png~";
330 366
331 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 367 make_file $path, $other, sub {
332 fork_sub { 368 fork_exec {
333 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~"; 369 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
334 system $OPTIPNG, "-i0", "-q", "$other~"; 370 system $OPTIPNG, "-i0", "-q", "$other~";
335 371
336 # reduce smoothfaces >10000 bytes 372 # reduce smoothfaces >10000 bytes
337 # obsolete, no longer required 373 # obsolete, no longer required
… …
352 } 388 }
353 389
354 die "$other~ has zero size, aborting." unless -s "$other~"; 390 die "$other~ has zero size, aborting." unless -s "$other~";
355 rename "$other~", $other; 391 rename "$other~", $other;
356 }; 392 };
357 } 393 };
358 394
359 #warn "scaled down $path to $other\n";#d# 395 #warn "scaled down $path to $other\n";#d#
360 push @c_png, [$other, !$CACHE]; 396 push @c_png, [$other, !$CACHE];
361 } 397 }
362 } 398 }
… …
376 } 412 }
377 413
378 my $mtime = (lstat $path)[9]; 414 my $mtime = (lstat $path)[9];
379 my @todo = grep { $_->[3] <= $mtime } @tile; 415 my @todo = grep { $_->[3] <= $mtime } @tile;
380 if (@todo) { 416 if (@todo) {
381 fork_sub { 417 fork_exec {
382 open my $convert, "|-", $CONVERT, 418 open my $convert, "|-", $CONVERT,
383 "png:-", 419 "png:-",
384 (map { 420 (map {
385 ( 421 (
386 "(", 422 "(",
… …
442 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5; 478 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
443 # bg not used except for text clients 479 # bg not used except for text clients
444 480
445 utf8::decode $glyph; 481 utf8::decode $glyph;
446 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag 482 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag
483 $glyph =~ s/^"(.+)"$/$1/; # allow for ""-style quoting
447 484
448 $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet 485 $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet
449 486
450 (my $fgi = $COLOR{$fg}) 487 (my $fgi = $COLOR{$fg})
451 // warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n"; 488 // warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n";
… …
579 } 616 }
580 617
581 $FILECACHE{$_[0]} 618 $FILECACHE{$_[0]}
582 } 619 }
583 620
621 # convert an image and a palette to some indexed 2d-matrix structure
622 sub process_plt {
623 my ($base, $plt) = @_;
624
625 my ($w, $h) = imgsize "$base.png";
626
627 $w * $h
628 or die "$base.png: unable to identify correct size\n";
629
630 my @plt;
631 my %map;
632
633 for (split /\n/, $plt) {
634 next unless /\S/;
635 next if /^\s*#/;
636
637 /^([0-9a-fA-F]{3,6})\s*(.*?)\s*$/
638 or die "unparseable palette entry for $base.plt: $_";
639
640 my ($rgb, $name) = ($1, $2);
641
642 $rgb =~ s/^(.)(.)(.)$/$1$1$2$2$3$3/;
643
644 $map{pack "H*", $rgb} = chr @plt;
645 push @plt, $name;
646 }
647
648 make_file ["$base.plt", "$base.png"], "$base.tbl~", sub {
649 warn "building $base\n" if $VERBOSE >= 3;
650
651 fork_exec {
652 open my $png, "-|", $CONVERT, qw(-depth 8 --), "$base.png", "rgb:"
653 or die "$base.png: $!";
654
655 local $/;
656 $png = <$png>;
657
658 $w * $h * 3 == length $png
659 or die "$base.png: failed to read enough data from file\n";
660
661 $png =~ s/(...)/$map{$1}/ge;
662
663 $w * $h == length $png
664 or die "$base.png: failed to map all data - wrong palette?\n";
665
666 {
667 open my $fh, ">:raw", "$base.tbl~~"
668 or die "$base.tbl~~: $!";
669 syswrite $fh, $png;
670 }
671
672 rename "$base.tbl~~", "$base.tbl~";
673 };
674 };
675
676 0 <= aio_load "$base.tbl~", my $tbl
677 or die "$base.tbl~: $!";
678
679 IO::AIO::aio_unlink "$base.tbl~" unless $CACHE;
680
681 Compress::LZF::compress nfreeze {
682 w => $w,
683 h => $h,
684 plt => \@plt,
685 tbl => $tbl,
686 }
687 }
688
584 sub process_res { 689 sub process_res {
585 my ($dir, $file, $type) = @_; 690 my ($dir, $file, $type) = @_;
586 691
587 my $data;
588 aio_load "$dir/$file", $data; 692 0 <= aio_load "$dir/$file", my $data
693 or die "$dir/$file: $!";
589 694
590 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) }; 695 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
591 696
592 utf8::decode $dir; 697 utf8::decode $dir;
593 utf8::decode $file; 698 utf8::decode $file;
… …
620 } 725 }
621 726
622 $file =~ s/\.res$//; 727 $file =~ s/\.res$//;
623 $file =~ s/\.(ogg|wav|jpg|png)$//; 728 $file =~ s/\.(ogg|wav|jpg|png)$//;
624 729
625 substr $dir, 0, 1 + length $PATH, ""; 730 if ($file =~ s/\.plt$//) {
626 731 $data = process_plt "$dir/$file", $data;
627 if (my $filter = $meta->{cfutil_filter}) { 732 } elsif (my $filter = $meta->{cfutil_filter}) {
628 if ($filter eq "yaml2json") { 733 if ($filter eq "yaml2json") {
629 $data = JSON::XS::encode_json YAML::XS::Load $data; 734 $data = JSON::XS::encode_json YAML::XS::Load $data;
630 } elsif ($filter eq "json2json") { 735 } elsif ($filter eq "json2json") {
631 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); 736 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
632 } elsif ($filter eq "perl2json") { 737 } elsif ($filter eq "perl2json") {
… …
634 $data = JSON::XS::encode_json $data; 739 $data = JSON::XS::encode_json $data;
635 } else { 740 } else {
636 warn "$dir/$file: unknown filter $filter, skipping\n"; 741 warn "$dir/$file: unknown filter $filter, skipping\n";
637 } 742 }
638 } 743 }
744
745 substr $dir, 0, 1 + length $PATH, "";
639 746
640 $RESOURCE{"$dir/$file"} = { 747 $RESOURCE{"$dir/$file"} = {
641 type => (exists $meta->{type} ? delete $meta->{type} : $type), 748 type => (exists $meta->{type} ? delete $meta->{type} : $type),
642 data => $data, 749 data => $data,
643 %$meta ? (meta => $meta) : (), 750 %$meta ? (meta => $meta) : (),
… …
753 if (!-d "$path/treasures") { 860 if (!-d "$path/treasures") {
754 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 861 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
755 exit 1 unless $FORCE; 862 exit 1 unless $FORCE;
756 } 863 }
757 864
758 print "start file scan, arc, any processing...\n" if $VERBOSE; 865 print "starting file scan, arc, any processing...\n" if $VERBOSE;
759 866
760 my @a_arc = map +(async \&process_arc), 1..2; 867 my @a_arc = map +(async \&process_arc), 1..2;
761 my @a_any = map +(async \&process_any), 1..4; 868 my @a_any = map +(async \&process_any), 1..4;
762 869
763 find_files $path; 870 find_files $path;
764 871
765 $c_arc->shutdown; 872 $c_arc->shutdown;
766 $c_any->shutdown; 873 $c_any->shutdown;
767 874
768 $_->join for @a_arc; # need to parse all archetypes before png processing 875 $_->join for @a_arc; # need to parse all archetypes before png processing
876 print "ended arc processing...\n" if $VERBOSE;
769 877
770 print "end arc, start png processing...\n" if $VERBOSE; 878 print "starting png processing...\n" if $VERBOSE;
771 879
772 # eight png crunchers work fine for my 4x smp machine 880 # eight png crunchers work fine for my 4x smp machine
773 my @a_png = map +(async \&process_png), 1..8; 881 my @a_png = map +(async \&process_png), 1..8;
774 882
775 print "end any processing...\n" if $VERBOSE;
776 $_->join for @a_any; 883 $_->join for @a_any;
777
778 print "end png processing...\n" if $VERBOSE; 884 print "ended any processing...\n" if $VERBOSE;
885
779 $_->join for @a_png; 886 $_->join for @a_png;
887 print "ended png processing...\n" if $VERBOSE;
780 888
781 print "scanning done, processing results...\n" if $VERBOSE; 889 print "scanning done, processing results...\n" if $VERBOSE;
782 { 890 {
783 # remove path prefix from editor_folder 891 # remove path prefix from editor_folder
784 $_->{editor_folder} =~ /^\x00/ 892 $_->{editor_folder} =~ /^\x00/
… …
911 version => 2, 1019 version => 2,
912 faceinfo => \%FACEINFO, 1020 faceinfo => \%FACEINFO,
913 animinfo => \%ANIMINFO, 1021 animinfo => \%ANIMINFO,
914 resource => \%RESOURCE, 1022 resource => \%RESOURCE,
915 }; 1023 };
916
917 } 1024 }
918 1025
919 print "committing files...\n" if $VERBOSE; 1026 print "committing files...\n" if $VERBOSE;
920 1027
921 for (qw(archetypes facedata treasures), @COMMIT) { 1028 for (qw(archetypes facedata treasures), @COMMIT) {

Diff Legend

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