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" }; |
59 | |
|
|
60 | sub WRITE_FACEINFO() { 0 } |
|
|
61 | |
62 | |
62 | sub usage { |
63 | sub usage { |
63 | warn <<EOF; |
64 | warn <<EOF; |
64 | Usage: cfutil [-v] [-q] [--force] [--cache] |
65 | Usage: cfutil [-v] [-q] [--force] [--cache] |
65 | [--install-arch path] |
66 | [--install-arch path] |
… | |
… | |
134 | } |
135 | } |
135 | |
136 | |
136 | mkdir $TMPDIR, 0700 |
137 | mkdir $TMPDIR, 0700 |
137 | or die "$TMPDIR: $!"; |
138 | or die "$TMPDIR: $!"; |
138 | |
139 | |
139 | sub fork_sub(&) { |
140 | sub 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 | |
|
|
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 | |
154 | sub inst_maps($) { |
184 | sub 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) { |