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.104 by root, Sat Oct 16 22:12:18 2010 UTC vs.
Revision 1.112 by root, Fri Apr 22 02:15:45 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 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.
… …
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" };
59
60sub WRITE_FACEINFO() { 0 }
61 62
62sub usage { 63sub usage {
63 warn <<EOF; 64 warn <<EOF;
64Usage: cfutil [-v] [-q] [--force] [--cache] 65Usage: cfutil [-v] [-q] [--force] [--cache]
65 [--install-arch path] 66 [--install-arch path]
… …
134} 135}
135 136
136mkdir $TMPDIR, 0700 137mkdir $TMPDIR, 0700
137 or die "$TMPDIR: $!"; 138 or die "$TMPDIR: $!";
138 139
139sub fork_sub(&) { 140sub fork_exec(&) {
140 my ($cb) = @_; 141 my ($cb) = @_;
141 142
142 if (my $pid = fork) { 143 if (my $pid = fork) {
143 my $current = $Coro::current; 144 my $current = $Coro::current;
144 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready }); 145 my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
… …
149 warn $@; 150 warn $@;
150 POSIX::_exit 1; 151 POSIX::_exit 1;
151 } 152 }
152} 153}
153 154
155sub 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
167sub 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
154sub inst_maps($) { 184sub inst_maps($) {
155 my (undef, $path) = @_; 185 my (undef, $path) = @_;
156 186
157 print "\nInstalling '$path' to '$DATADIR/maps'\n\n"; 187 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
158 188
… …
166 "--exclude", "CVS", "--exclude", "/world-precomposed", 196 "--exclude", "CVS", "--exclude", "/world-precomposed",
167 "--delete", "--delete-excluded" 197 "--delete", "--delete-excluded"
168 and die "map installation failed.\n"; 198 and die "map installation failed.\n";
169 199
170 print "maps installed successfully.\n"; 200 print "maps installed successfully.\n";
171}
172
173{
174 no utf8; # == values are utf-8 encoded
175
176 our @WALL_SUFFIX = qw(⬤ ╹ ╺ ┗ ╻ ┃ ┏ ┣ ╸ ┛ ━ ┻ ┓ ┫ ┳ ╋);
177
178 # used to create crude text glyphs for text-based clients
179 sub autoglyph {
180 my ($stem, $face) = @_;
181
182 if ($stem =~ /^wall\/|Nimwall/) {
183 return $WALL_SUFFIX[hex $1]
184 if $stem =~ /(_[0-9A-F]).x11/;
185
186 "█"
187
188 } elsif ($stem =~ /^traps\//) {
189 "☠"
190
191 } elsif ($stem =~ /^armour\/shield/) {
192 "Ø"
193
194 } elsif ($stem =~ /^armour\//) {
195 "A"
196
197 } elsif ($stem =~ /^weapon\//) {
198 "†"
199
200 } elsif ($stem =~ /^readable\//) {
201 "✉"
202
203 } elsif ($stem =~ /^river\//) {
204 "~"
205
206 } elsif ($stem =~ /^floor\/|^ground\/|Nimfloor/) {
207 "·"
208
209 } elsif ($stem =~ /^spells\//) {
210 "!"
211
212 } elsif ($stem =~ /^exit\//) {
213 "⎆"
214
215 } elsif ($stem =~ /^construct\//) {
216 "⌂"
217
218 } elsif ($stem =~ /^player\//) {
219 "\@"
220
221 } elsif ($stem =~ /^(?:monster|misc|class|connect|gods|indoor|inorganic|mining|music|skills).*\/(.)/) {
222 $1
223
224 } else {
225 substr $stem, 0, 1
226 }
227 }
228} 201}
229 202
230{ 203{
231 our %ANIMINFO; 204 our %ANIMINFO;
232 our %FACEINFO; 205 our %FACEINFO;
… …
307 unless ($path =~ /~$/) { 280 unless ($path =~ /~$/) {
308 # possibly enlarge 281 # possibly enlarge
309 if (0 > aio_stat "$stem.64x64.png") { 282 if (0 > aio_stat "$stem.64x64.png") {
310 my $other = "$stem.64x64.png~"; 283 my $other = "$stem.64x64.png~";
311 284
312 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 285 make_file $path, $other, sub {
313 fork_sub { 286 fork_exec {
314 my $CROP; 287 my $CROP;
315 my $SRC = "png:\Q$path\E"; 288 my $SRC = "png:\Q$path\E";
316 289
317 my $is_floor = $arc->{is_floor}; 290 my $is_floor = $arc->{is_floor};
318 my $is_wall = 0; 291 my $is_wall = 0;
… …
376 and die "convert/cfhq2xa pipeline error: status $? ($!)"; 349 and die "convert/cfhq2xa pipeline error: status $? ($!)";
377 system $OPTIPNG, "-i0", "-q", "$other~"; 350 system $OPTIPNG, "-i0", "-q", "$other~";
378 die "$other~ has zero size, aborting." unless -s "$other~"; 351 die "$other~ has zero size, aborting." unless -s "$other~";
379 rename "$other~", $other; 352 rename "$other~", $other;
380 }; 353 };
381 } 354 };
382 355
383 push @c_png, [$other, !$CACHE]; 356 push @c_png, [$other, !$CACHE];
384 } 357 }
385 358
386 # possibly scale down 359 # possibly scale down
387 if (0 > aio_stat "$stem.32x32.png") { 360 if (0 > aio_stat "$stem.32x32.png") {
388 my $other = "$stem.32x32.png~"; 361 my $other = "$stem.32x32.png~";
389 362
390 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 363 make_file $path, $other, sub {
391 fork_sub { 364 fork_exec {
392 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~";
393 system $OPTIPNG, "-i0", "-q", "$other~"; 366 system $OPTIPNG, "-i0", "-q", "$other~";
394 367
395 # reduce smoothfaces >10000 bytes 368 # reduce smoothfaces >10000 bytes
396 # obsolete, no longer required 369 # obsolete, no longer required
… …
411 } 384 }
412 385
413 die "$other~ has zero size, aborting." unless -s "$other~"; 386 die "$other~ has zero size, aborting." unless -s "$other~";
414 rename "$other~", $other; 387 rename "$other~", $other;
415 }; 388 };
416 } 389 };
417 390
418 #warn "scaled down $path to $other\n";#d# 391 #warn "scaled down $path to $other\n";#d#
419 push @c_png, [$other, !$CACHE]; 392 push @c_png, [$other, !$CACHE];
420 } 393 }
421 } 394 }
… …
435 } 408 }
436 409
437 my $mtime = (lstat $path)[9]; 410 my $mtime = (lstat $path)[9];
438 my @todo = grep { $_->[3] <= $mtime } @tile; 411 my @todo = grep { $_->[3] <= $mtime } @tile;
439 if (@todo) { 412 if (@todo) {
440 fork_sub { 413 fork_exec {
441 open my $convert, "|-", $CONVERT, 414 open my $convert, "|-", $CONVERT,
442 "png:-", 415 "png:-",
443 (map { 416 (map {
444 ( 417 (
445 "(", 418 "(",
… …
495 warn "$path: $!, skipping.\n"; 468 warn "$path: $!, skipping.\n";
496 return; 469 return;
497 } 470 }
498 471
499 for (split /\n/, $data) { 472 for (split /\n/, $data) {
473 chomp;
500 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/; 474 my ($face, $visibility, $fg, $bg, $glyph) = split /\s+/, $_, 5;
475 # bg not used except for text clients
501 476
477 utf8::decode $glyph;
502 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag 478 $glyph =~ s/^\?(?=.)//; # remove "autoglyph" flag
479 $glyph =~ s/^"(.+)"$/$1/; # allow for ""-style quoting
480
481 $fg = "white" if $fg eq "none"; # lots of faces have no fg colour yet
503 482
504 (my $fgi = $COLOR{$fg}) 483 (my $fgi = $COLOR{$fg})
505 // warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n"; 484 // warn "WARNING: $path: $face specifies unknown foreground colour '$fg'.\n";
506 (my $bgi = $COLOR{$bg}) 485 (my $bgi = $COLOR{$bg})
507 // warn "WARNING: $path: $face specifies unknown background colour '$bg'.\n"; 486 // warn "WARNING: $path: $face specifies unknown background colour '$bg'.\n";
508 487
509 my $fi = $FACEINFO{$face} ||= { }; 488 my $fi = $FACEINFO{$face} ||= { };
510 $fi->{visibility} = $visibility * 1; 489 $fi->{visibility} = $visibility * 1;
511 $fi->{magicmap} = $fgi; # foreground colour becomes magicmap 490 $fi->{magicmap} = $fgi; # foreground colour becomes magicmap
491
492 $glyph .= " " if 2 > length $glyph; # TODO kanji
493 die "glyph $face too long" if 2 < length $glyph;
494
495 $fi->{glyph} = "";
496 for (split //, $glyph) {
497 utf8::encode $_;
512 $fi->{glyph} = (chr $fgi) . (chr $bgi) . $glyph; 498 $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
513 #$fi->{glyph} = (chr $fgi) . $glyph;#d#TOOD remove 499 }
514 # bg not used except for text clients
515 } 500 }
516 } 501 }
517 502
518 sub process_arc { 503 sub process_arc {
519 while (my ($dir, $file) = @{ $c_arc->get }) { 504 while (my ($dir, $file) = @{ $c_arc->get }) {
… …
627 } 612 }
628 613
629 $FILECACHE{$_[0]} 614 $FILECACHE{$_[0]}
630 } 615 }
631 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
632 sub process_res { 685 sub process_res {
633 my ($dir, $file, $type) = @_; 686 my ($dir, $file, $type) = @_;
634 687
635 my $data;
636 aio_load "$dir/$file", $data; 688 0 <= aio_load "$dir/$file", my $data
689 or die "$dir/$file: $!";
637 690
638 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) };
639 692
640 utf8::decode $dir; 693 utf8::decode $dir;
641 utf8::decode $file; 694 utf8::decode $file;
… …
668 } 721 }
669 722
670 $file =~ s/\.res$//; 723 $file =~ s/\.res$//;
671 $file =~ s/\.(ogg|wav|jpg|png)$//; 724 $file =~ s/\.(ogg|wav|jpg|png)$//;
672 725
673 substr $dir, 0, 1 + length $PATH, ""; 726 if ($file =~ s/\.plt$//) {
674 727 $data = process_plt "$dir/$file", $data;
675 if (my $filter = $meta->{cfutil_filter}) { 728 } elsif (my $filter = $meta->{cfutil_filter}) {
676 if ($filter eq "yaml2json") { 729 if ($filter eq "yaml2json") {
677 $data = JSON::XS::encode_json YAML::XS::Load $data; 730 $data = JSON::XS::encode_json YAML::XS::Load $data;
678 } elsif ($filter eq "json2json") { 731 } elsif ($filter eq "json2json") {
679 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data); 732 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
680 } elsif ($filter eq "perl2json") { 733 } elsif ($filter eq "perl2json") {
… …
682 $data = JSON::XS::encode_json $data; 735 $data = JSON::XS::encode_json $data;
683 } else { 736 } else {
684 warn "$dir/$file: unknown filter $filter, skipping\n"; 737 warn "$dir/$file: unknown filter $filter, skipping\n";
685 } 738 }
686 } 739 }
740
741 substr $dir, 0, 1 + length $PATH, "";
687 742
688 $RESOURCE{"$dir/$file"} = { 743 $RESOURCE{"$dir/$file"} = {
689 type => (exists $meta->{type} ? delete $meta->{type} : $type), 744 type => (exists $meta->{type} ? delete $meta->{type} : $type),
690 data => $data, 745 data => $data,
691 %$meta ? (meta => $meta) : (), 746 %$meta ? (meta => $meta) : (),
… …
887 open my $fh, ">:utf8", "$DATADIR/archetypes~" 942 open my $fh, ">:utf8", "$DATADIR/archetypes~"
888 or die "$DATADIR/archetypes~: $!"; 943 or die "$DATADIR/archetypes~: $!";
889 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC]; 944 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
890 } 945 }
891 946
892 if (WRITE_FACEINFO) {
893 my @table;
894 for my $face (sort keys %FACEINFO) {
895 my $v = $FACEINFO{$face};
896 (my $xf = $face) =~ s/\+\d+\+\d+$//;
897
898 $v->{magicmap} //= $FACEINFO{$xf}{magicmap};
899 $v->{glyph} //= $FACEINFO{$xf}{glyph};
900
901 $v->{magicmap} =~ y/A-Z_\-/a-z/d;
902
903 delete $v->{glyph} if $v->{glyph} =~ /^\?./;
904
905 my $stem = $v->{stem};
906 $v->{glyph} = $v->{glyph} // ("?" . (autoglyph $stem, $v));
907
908 push @table, [$face, $v->{visibility} || 0, $v->{magicmap} || "none", "none ", $v->{glyph}];
909 }
910 use Text::Table;
911 my $tb = new Text::Table undef, { align => "num" }, undef, undef, undef;
912 $tb->load (@table);
913 open my $fh, ">:raw", "default.faceinfo"or die;
914 print $fh $tb;
915 print "default.faceinfo written, exiting.\n";
916 exit 77;
917 }
918
919 { 947 {
920 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE; 948 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
921 open my $fh, ">:utf8", "$DATADIR/treasures~" 949 open my $fh, ">:utf8", "$DATADIR/treasures~"
922 or die "$DATADIR/treasures~: $!"; 950 or die "$DATADIR/treasures~: $!";
923 print $fh $TRS; 951 print $fh $TRS;
… …
933 make_hash $k, $v->{data64}, $v->{hash64}; 961 make_hash $k, $v->{data64}, $v->{hash64};
934 962
935 #length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n"; 963 #length $v->{data32} <= 10000 or warn "WARNING: face '$k' has face32 larger than 10000 bytes, will not work with crossfire client.\n";
936 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n"; 964 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
937 965
938 exists $v->{visibility}
939 or warn "WARNING: face '$k' has no visibility info, missing faceinfo entry?\n";
940
941 my $stem = delete $v->{stem};
942 $v->{glyph} // warn "WARNING: face '$k' has glyph, cannot autoglyph at the moment."; 966 $v->{glyph} // warn "WARNING: face '$k' has glyph.";
943 #$v->{glyph} //= autoglyph $stem, $v; 967 $v->{visibility} // warn "WARNING: face '$k' has no visibility info, missing faceinfo entry?\n";
968 $v->{magicmap} // warn "WARNING: face '$k' has foreground colour.";
944 969
945 delete $v->{arc}; 970 delete @$v{qw(arc stem)}; # not used by the server
946 } 971 }
947 972
948 print "processing resources...\n" if $VERBOSE; 973 print "processing resources...\n" if $VERBOSE;
949 my $enc = JSON::XS->new->utf8->canonical->relaxed; 974 my $enc = JSON::XS->new->utf8->canonical->relaxed;
950 while (my ($k, $v) = each %RESOURCE) { 975 while (my ($k, $v) = each %RESOURCE) {
… …
989 version => 2, 1014 version => 2,
990 faceinfo => \%FACEINFO, 1015 faceinfo => \%FACEINFO,
991 animinfo => \%ANIMINFO, 1016 animinfo => \%ANIMINFO,
992 resource => \%RESOURCE, 1017 resource => \%RESOURCE,
993 }; 1018 };
994
995 } 1019 }
996 1020
997 print "committing files...\n" if $VERBOSE; 1021 print "committing files...\n" if $VERBOSE;
998 1022
999 for (qw(archetypes facedata treasures), @COMMIT) { 1023 for (qw(archetypes facedata treasures), @COMMIT) {

Diff Legend

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