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.27 by root, Wed Apr 18 07:59:03 2007 UTC vs.
Revision 1.97 by root, Wed Oct 6 01:23:11 2010 UTC

1#!@PERL@ 1#!@PERL@
2 2
3use strict; 3#
4# This file is part of Deliantra, the Roguelike Realtime MMORPG.
5#
6# Copyright (©) 2007,2008,2009 Marc Alexander Lehmann / Robin Redeker / the Deliantra team
7#
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
10# Free Software Foundation, either version 3 of the License, or (at your
11# option) any later version.
12#
13# This program is distributed in the hope that it will be useful,
14# but WITHOUT ANY WARRANTY; without even the implied warranty of
15# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16# GNU General Public License for more details.
17#
18# You should have received a copy of the Affero GNU General Public License
19# and the GNU General Public License along with this program. If not, see
20# <http://www.gnu.org/licenses/>.
21#
22# The authors can be reached via e-mail to <support@deliantra.net>
23#
24
25use common::sense;
4 26
5my $prefix = "@prefix@"; 27my $prefix = "@prefix@";
6my $exec_prefix = "@exec_prefix@"; 28my $exec_prefix = "@exec_prefix@";
7my $datarootdir = "@datarootdir@"; 29my $datarootdir = "@datarootdir@";
8my $DATADIR = "@datadir@/@PACKAGE@"; 30my $DATADIR = "@datadir@/@PACKAGE@";
9 31
10my $CONVERT = "@CONVERT@"; 32my $CONVERT = "@CONVERT@";
11my $IDENTIFY = "@IDENTIFY@"; 33#my $IDENTIFY = "@IDENTIFY@";
12my $OPTIPNG = "@OPTIPNG@"; 34my $OPTIPNG = "@OPTIPNG@";
13my $RSYNC = "@RSYNC@"; 35my $RSYNC = "@RSYNC@";
36my $PNGNQ = "@PNGNQ@";
14 37
15use Getopt::Long; 38use Getopt::Long;
39use File::Temp;
40use POSIX ();
41use Carp;
42
16use Coro::Event; 43use Coro::EV;
17use AnyEvent; 44use AnyEvent;
45use YAML::XS ();
46use JSON::XS ();
18use IO::AIO (); 47use IO::AIO ();
19use File::Temp; 48use Digest::MD5 ();
20use Crossfire; 49
21use Coro; 50use Coro 5.12;
22use Coro::AIO; 51use Coro::AIO;
23use POSIX (); 52use Coro::Util;
24use Digest::MD5; 53use Coro::Channel;
25use Coro::Storable; $Storable::canonical = 1; 54use Coro::Storable; $Storable::canonical = 1;
55
56use Deliantra;
57
58$SIG{QUIT} = sub { Carp::cluck "QUIT" };
26 59
27sub usage { 60sub usage {
28 warn <<EOF; 61 warn <<EOF;
29Usage: cfutil [-v] [-q] [--force] [--cache] 62Usage: cfutil [-v] [-q] [--force] [--cache]
30 [--install-arch path] 63 [--install-arch path]
… …
41my $VERBOSE = 1; 74my $VERBOSE = 1;
42my $CACHE = 0; 75my $CACHE = 0;
43my $FORCE; 76my $FORCE;
44my $TMPDIR = "/tmp/cfutil$$~"; 77my $TMPDIR = "/tmp/cfutil$$~";
45my $TMPFILE = "aaaa0"; 78my $TMPFILE = "aaaa0";
79my @COMMIT;
80
81our %COLOR = (
82 black => 0,
83 white => 1,
84 navy => 2,
85 red => 3,
86 orange => 4,
87 blue => 5,
88 darkorange => 6,
89 green => 7,
90 lightgreen => 8,
91 grey => 9,
92 brown => 10,
93 gold => 11,
94 tan => 12,
95);
46 96
47END { system "rm", "-rf", $TMPDIR } 97END { system "rm", "-rf", $TMPDIR }
48 98
49Event->signal (signal => "INT", cb => sub { exit 1 }); 99my $s_INT = EV::signal INT => sub { exit 1 };
50Event->signal (signal => "TERM", cb => sub { exit 1 }); 100my $s_TERM = EV::signal TERM => sub { exit 1 };
101
102our %hash;
103
104# here we could try to avoid collisions and reduce chksum size further
105sub make_hash($\$\$;$) {
106 my ($id, $dataref, $hashref, $clen) = @_;
107
108 my $hash = substr +(Digest::MD5::md5 $$dataref), 0, $clen || 4;
109
110 if (exists $hash{$hash}) {
111 # hash collision, but some files are simply identical
112 if (${$hash{$hash}[1]} ne $$dataref) {
113 warn "hash collision $hash{$hash}[0] vs. $id\n";
114 exit 1;
115 } else {
116 print "$hash{$hash}[0] and $id are identical (which is fine).\n" if $VERBOSE >= 3;
117 }
118 }
119 $hash{$hash} = [$id, $dataref, $hashref];
120
121 $$hashref = $hash;
122}
51 123
52mkdir $TMPDIR, 0700 124mkdir $TMPDIR, 0700
53 or die "$TMPDIR: $!"; 125 or die "$TMPDIR: $!";
54 126
55sub fork_sub(&) { 127sub fork_sub(&) {
… …
68} 140}
69 141
70sub inst_maps($) { 142sub inst_maps($) {
71 my (undef, $path) = @_; 143 my (undef, $path) = @_;
72 144
73 print "installing '$path' to '$DATADIR/maps'\n"; 145 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
74 146
75 if (!-f "$path/regions") { 147 if (!-f "$path/regions") {
76 warn "'$path' does not look like a maps directory ('regions' file is missing).\n"; 148 warn "'$path' does not look like a maps directory ('regions' file is missing).\n";
77 exit 1 unless $FORCE; 149 exit 1 unless $FORCE;
78 } 150 }
79 151
80 system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded" 152 system $RSYNC, "-av", "--chmod=u=rwX,go=rX",
153 "$path/.", "$DATADIR/maps/.",
154 "--exclude", "CVS", "--exclude", "/world-precomposed",
155 "--delete", "--delete-excluded"
81 and die "map installation failed.\n"; 156 and die "map installation failed.\n";
82 157
83 print "maps installed successfully.\n"; 158 print "maps installed successfully.\n";
159}
160
161our @WALL_SUFFIX = qw(⬤ ╹ ╺ ┗ ╻ ┃ ┏ ┣ ╸ ┛ ━ ┻ ┓ ┫ ┳ ╋);
162
163# used to create crude text glyphs for text-based clients
164sub autoglyph {
165 my ($stem, $face) = @_;
166
167 if ($stem =~ /^wall\/|Nimwall/) {
168 return $WALL_SUFFIX[hex $1]
169 if $stem =~ /(_[0-9A-F]).x11/;
170
171 "+"
172
173 } elsif ($stem =~ /^monster.*\/(.)/) {
174 $1
175
176 } elsif ($stem =~ /^floor\/|^ground\/|Nimfloor/) {
177 "."
178
179 } elsif ($stem =~ /^player\//) {
180 "\@"
181
182 } else {
183 substr $stem, 0, 1
184 }
84} 185}
85 186
86{ 187{
87 our %ANIMINFO; 188 our %ANIMINFO;
88 our %FACEINFO; 189 our %FACEINFO;
190 our %RESOURCE;
191 our @ARC;
89 our %ARC; 192 our %ARC;
90 our $TRS; 193 our $TRS;
91 our $NFILE; 194 our $NFILE;
195 our $PATH;
92 196
93 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 197 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
94 198
95 our (@png, @trs, @arc); # files we are interested in 199 our $c_arc = new Coro::Channel;
200 our $c_trs = new Coro::Channel;
201 our $c_res = new Coro::Channel;
96 202
203 our @c_png;
204
97 sub commit_png($$$) { 205 sub commit_png($$$$) {
98 my ($name, $data, $T) = @_; 206 my ($stem, $name, $data, $T) = @_;
99 207
208 $FACEINFO{$name}{"stem"} = substr $stem, 1 + length $PATH;
100 $FACEINFO{$name}{"data$T"} = $data; 209 $FACEINFO{$name}{"data$T"} = $data;
101 } 210 }
102 211
103 sub process_png { 212 sub process_png {
104 while (@png) { 213 while (@c_png) {
105 my ($path, $delete) = @{pop @png}; 214 my ($path, $delete) = @{pop @c_png};
106 215
107 my $png; 216 my $png;
108 aio_lstat $path; 217 aio_lstat $path;
109 my ($size, $mtime) = (stat _)[7,9]; 218 my ($size, $mtime) = (stat _)[7,9];
110 219
… …
141 if ($w % $T || $h % $T) { 250 if ($w % $T || $h % $T) {
142 warn "$path: weird png size ($w $h), skipping.\n"; 251 warn "$path: weird png size ($w $h), skipping.\n";
143 next; 252 next;
144 } 253 }
145 254
255 (my $base = $stem) =~ s/^.*\///;
256
257 my $fi = $FACEINFO{$base};
258 unless ($fi) {
259 #warn "$path: <$base> not referenced by any archetype, skipping.\n";
260 #next;
261 }
262
263 my $arc = $fi->{arc} || { };
264
146 unless ($path =~ /~$/) { 265 unless ($path =~ /~$/) {
147 # possibly enlarge 266 # possibly enlarge
148 if (0 > aio_stat "$stem.64x64.png") { 267 if (0 > aio_stat "$stem.64x64.png") {
149 my $other = "$stem.64x64.png~"; 268 my $other = "$stem.64x64.png~";
150 269
151 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 270 if (0 > aio_lstat $other or (-M _) > (-M $path)) {
152 my $wrap = 0; # for the time being
153 fork_sub { 271 fork_sub {
272 my $CROP;
273 my $SRC = "png:\Q$path\E";
274
275 my $is_floor = $arc->{is_floor};
276 my $is_wall = 0;
277
278 my ($wall_pfx, $wall_dir, $wall_sfx);
279
280 if (
281 !$is_floor
282 && !$arc->{alive}
283 && $arc->{move_block} eq "all"
284 && $path =~ /^(.*_)([0-9A-F])(\.x11.*\.png)$/
285 ) {
286 ($wall_pfx, $wall_dir, $wall_sfx) = ($1, hex $2, $3);
287
288 unless (grep { !-e sprintf "%s%X%s", $wall_pfx, $_, $wall_sfx } 0..15) {
289 $is_wall = 1;
290 }
291 }
292
293 if ($is_wall || $is_floor) {
294 # add a 4px border and add other images around it
295 $CROP = "-shave 8x8 +repage";
296
297 $w += 8;
298 $h += 8;
299
300 $SRC = "-size ${w}x${h} xc:transparent";
301 $SRC .= " png:\Q$path\E -geometry +4+4 -composite";
302
303 # 8 surrounding images
304 for (
305 # x y b r0 r1
306 [-1, -1, 0, 6],
307 [ 0, -1, 1, 10, 14],
308 [+1, -1, 0, 12],
309
310 [-1, 0, 8, 5, 7],
311 #
312 [+1, 0, 2, 5, 13],
313
314 [-1, +1, 0, 3],
315 [ 0, +1, 4, 10, 11],
316 [+1, +1, 0, 9],
317 ) {
318 my ($x, $y, $d, $r0, $r1) = @$_;
319
320 my $tile = $is_floor ? $path
321 : $is_wall ? sprintf "%s%X%s", $wall_pfx, ($wall_dir & $d) ? $r1 : $r0, $wall_sfx
322 : die;
323
324 $SRC .= sprintf " png:%s -geometry %+d%+d -composite",
325 "\Q$tile",
326 $x * ($w - 8) + 4,
327 $y * ($h - 8) + 4;
328 }
329 }
330
154 system "convert png:\Q$path\E -depth 8 rgba:-" 331 system "convert -depth 8 $SRC rgba:-"
155 . "| $exec_prefix/bin/cfhq2xa $w $h $wrap" 332 . "| $exec_prefix/bin/cfhq2xa $w $h 0"
156 . "| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $QUANTIZE -quality 00 png32:\Q$other\E~" 333 . "| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $CROP $QUANTIZE -quality 00 png32:\Q$other\E~"
157 and die "convert/hq2xa pipeline error: status $? ($!)"; 334 and die "convert/cfhq2xa pipeline error: status $? ($!)";
158 system $OPTIPNG, "-o5", "-i0", "-q", "$other~"; 335 system $OPTIPNG, "-i0", "-q", "$other~";
159 die "$other~ has zero size, aborting." unless -s "$other~"; 336 die "$other~ has zero size, aborting." unless -s "$other~";
160 rename "$other~", $other; 337 rename "$other~", $other;
161 }; 338 };
162 } 339 }
163 340
164 push @png, [$other, !$CACHE]; 341 push @c_png, [$other, !$CACHE];
165 } 342 }
166 343
167 # possibly scale down 344 # possibly scale down
168 if (0 > aio_stat "$stem.32x32.png") { 345 if (0 > aio_stat "$stem.32x32.png") {
169 my $other = "$stem.32x32.png~"; 346 my $other = "$stem.32x32.png~";
170 347
171 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 348 if (0 > aio_lstat $other or (-M _) > (-M $path)) {
172 fork_sub { 349 fork_sub {
173 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~"; 350 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
174 system $OPTIPNG, "-o5", "-i0", "-q", "$other~"; 351 system $OPTIPNG, "-i0", "-q", "$other~";
352
353 # reduce smoothfaces >10000 bytes
354 # obsolete, no longer required
355 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
356 my $ncolor = 256;
357 while () {
358 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
359 system $OPTIPNG, "-i0", "-q", "$other~~";
360 last if 10000 > -s "$other~~";
361 $ncolor = int $ncolor * 0.9;
362 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
363 }
364
365 printf "reduced %s from %d to %d bytes using %d colours.\n",
366 $other, -s "$other~", -s "$other~~", $ncolor
367 if $VERBOSE >= 2;
368 rename "$other~~", "$other~";
369 }
370
175 die "$other~ has zero size, aborting." unless -s "$other~"; 371 die "$other~ has zero size, aborting." unless -s "$other~";
176 rename "$other~", $other; 372 rename "$other~", $other;
177 }; 373 };
178 } 374 }
179 375
180 #warn "scaled down $path to $other\n";#d# 376 #warn "scaled down $path to $other\n";#d#
181 push @png, [$other, !$CACHE]; 377 push @c_png, [$other, !$CACHE];
182 } 378 }
183 } 379 }
184 380
185 (my $face = $stem) =~ s/^.*\///; 381 (my $face = $stem) =~ s/^.*\///;
186 382
… …
235 431
236 if (0 > aio_load $file, $tile) { 432 if (0 > aio_load $file, $tile) {
237 die "$path: unable to read tile +$x+$y, aborting.\n"; 433 die "$path: unable to read tile +$x+$y, aborting.\n";
238 } 434 }
239 IO::AIO::aio_unlink $file unless $CACHE; 435 IO::AIO::aio_unlink $file unless $CACHE;
240 commit_png $x|$y ? "$face+$x+$y" : $face, $tile, $T; 436 commit_png $stem, $x|$y ? "$face+$x+$y" : $face, $tile, $T;
241 } 437 }
242 } else { 438 } else {
243 # use as-is (either small, use smooth) 439 # use as-is (either small, use smooth)
244 commit_png $face, $png, $T; 440 commit_png $stem, $face, $png, $T;
245 } 441 }
246 442
247 aio_unlink $path if $delete; 443 aio_unlink $path if $delete;
248 } 444 }
249 } 445 }
250 446
251 sub process_arc { 447 sub process_arc {
252 while (@arc) { 448 while (my $job = $c_arc->get) {
253 my ($dir, $file) = @{pop @arc}; 449 my ($dir, $file) = @$job;
254 450
255 my $arc; 451 my $arc;
256 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/ 452 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
257 453
258 my $arc = read_arch "$dir/$file"; 454 my $arc = read_arch "$dir/$file";
259 for my $o (values %$arc) { 455 for my $o (values %$arc) {
456 push @ARC, $o;
457 for (my $m = $o; $m; $m = $m->{more}) {
260 $ARC{$o->{_name}} = $o; 458 $ARC{$m->{_name}} = $m;
459 }
261 460
262 $o->{editor_folder} = $dir; 461 $o->{editor_folder} ||= "\x00$dir"; # horrible kludge
263 462
264 my $visibility = delete $o->{visibility}; 463 my $visibility = delete $o->{visibility};
265 my $magicmap = delete $o->{magicmap}; 464 my $magicmap = delete $o->{magicmap};
465 my $glyph = delete $o->{glyph};
266 466
267 # find upper left corner :/ 467 # find upper left corner :/
268 # omg, this is sooo broken 468 # omg, this is sooo broken
269 my ($dx, $dy); 469 my ($dx, $dy);
270 for (my $o = $o; $o; $o = $o->{more}) { 470 for (my $o = $o; $o; $o = $o->{more}) {
… …
278 478
279 my $ext = $x|$y ? "+$x+$y" : ""; 479 my $ext = $x|$y ? "+$x+$y" : "";
280 480
281 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face}; 481 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face};
282 482
283 my $visibility = delete $o->{visibility} if exists $o->{visibility}; 483 $visibility = delete $o->{visibility} if exists $o->{visibility};
284 my $magicmap = delete $o->{magicmap} if exists $o->{magicmap}; 484 $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
485 $glyph = delete $o->{glyph} if exists $o->{glyph};
285 486
286 my $anim = delete $o->{anim}; 487 my $anim = delete $o->{anim};
287 488
288 if ($anim) { 489 if ($anim) {
289 # possibly add $ext to the animation name to avoid 490 # possibly add $ext to the animation name to avoid
… …
307 facings => $facings, 508 facings => $facings,
308 frames => \@frames, 509 frames => \@frames,
309 }; 510 };
310 } 511 }
311 512
312 for my $face ($o->{face} || (), @{$anim || []}) { 513 for ($o->{face} || (), @{$anim || []}) {
313 next if $face =~ /^facings\s|^blank.x11$|^empty.x11$/; 514 next if /^facings\s/;
314 515
516 my $face = $_;
517 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
518
315 my $info = $FACEINFO{$face} ||= {}; 519 my $info = $FACEINFO{$face} ||= { };
520 $info->{arc} = $o;
521
522 next if $face =~ /^blank.x11$|^empty.x11$/;
316 523
317 $info->{visibility} = $visibility if defined $visibility; 524 $info->{visibility} = $visibility if defined $visibility;
318 $info->{magicmap} = $magicmap if defined $magicmap; 525 $info->{magicmap} = $magicmap if defined $magicmap;
526 $info->{glyph} = $glyph if defined $glyph;
319 } 527 }
320 528
321 if (my $smooth = delete $o->{smoothface}) { 529 if (my $smooth = delete $o->{smoothface}) {
322 my %kv =split /\s+/, $smooth; 530 my %kv = split /\s+/, $smooth;
323 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 531 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
324 while (my ($face, $smooth) = each %kv) { 532 while (my ($face, $smooth) = each %kv) {
533 $FACEINFO{$smooth}{arc} = $o;
534
325 $FACEINFO{$face}{smooth} = $smooth; 535 $FACEINFO{$face}{smooth} = $smooth;
326 $FACEINFO{$face}{smoothlevel} = $level; 536 $FACEINFO{$face}{smoothlevel} = $level;
327 } 537 }
328 } 538 }
329 } 539 }
330 } 540 }
331 } 541 }
332 } 542 }
333 543
334 sub process_trs { 544 sub process_trs {
335 while (@trs) { 545 while (my $job = $c_trs->get) {
336 my ($dir, $file) = @{pop @trs}; 546 my ($dir, $file) = @$job;
337 my $path = "$dir/$file"; 547 my $path = "$dir/$file";
338 548
339 my $trs; 549 my $trs;
340 if (0 > aio_load $path, $trs) { 550 if (0 > aio_load $path, $trs) {
341 warn "$path: $!, skipping.\n"; 551 warn "$path: $!, skipping.\n";
… …
344 554
345 $TRS .= $trs; 555 $TRS .= $trs;
346 } 556 }
347 } 557 }
348 558
559 my %FILECACHE;
560
561 sub load_cached($;$) {
562 unless (exists $FILECACHE{$_[0]}) {
563 my $data;
564 if (0 < aio_load $_[0], $data) {
565 if ($_[1]) {
566 $data = eval { $_[1]->($data) };
567 warn "$_[0]: $@" if $@;
568 }
569 }
570
571 $FILECACHE{$_[0]} = $data;
572 }
573
574 $FILECACHE{$_[0]}
575 }
576
577 sub process_res {
578 while (my $job = $c_res->get) {
579 my ($dir, $file, $type) = @$job;
580
581 my $data;
582 aio_load "$dir/$file", $data;
583
584 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
585
586 utf8::decode $dir;
587 utf8::decode $file;
588
589 # a meta file for resources is now mandatory
590 unless (exists $meta->{$file}) {
591 warn "skipping $dir/$file\n" if $VERBOSE >= 3;
592 next;
593 }
594
595 $meta = {
596 %{ $meta->{"" } || {} },
597 %{ $meta->{$file} || {} },
598 };
599
600 if ($meta->{license} =~ s/^#//) {
601 $meta->{license} = ({
602 "pd" => "Public Domain",
603 "gpl" => "GNU General Public License, version 3.0 or any later",
604 "cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
605 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
606 "cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
607 "cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
608 })->{$meta->{license}}
609 || warn "$dir/$file: license tag '$meta->{license}' not found.";
610 }
611
612 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
613 ($meta->{author} = $1) =~ s/_/ /g;
614 }
615
616 $file =~ s/\.res$//;
617 $file =~ s/\.(ogg|wav|jpg|png)$//;
618
619 substr $dir, 0, 1 + length $PATH, "";
620
621 if (my $filter = $meta->{cfutil_filter}) {
622 if ($filter eq "yaml2json") {
623 $data = JSON::XS::encode_json YAML::XS::Load $data;
624 } elsif ($filter eq "json2json") {
625 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
626 } elsif ($filter eq "perl2json") {
627 $data = eval $data; die if $@;
628 $data = JSON::XS::encode_json $data;
629 } else {
630 warn "$dir/$file: unknown filter $filter, skipping\n";
631 }
632 }
633
634 $RESOURCE{"$dir/$file"} = {
635 type => (exists $meta->{type} ? delete $meta->{type} : $type),
636 data => $data,
637 %$meta ? (meta => $meta) : (),
638 };
639 }
640 }
641
349 sub find_files; 642 sub find_files;
350 sub find_files { 643 sub find_files {
351 my ($path) = @_; 644 my ($path) = @_;
352 645
353 IO::AIO::aioreq_pri 4; 646 IO::AIO::aioreq_pri 4;
354 IO::AIO::aio_scandir $path, 4, sub { 647 IO::AIO::aio_scandir $path, 4, sub {
355 my ($dirs, $nondirs) = @_; 648 my ($dirs, $nondirs) = @_;
356 649
357 find_files "$path/$_" 650 find_files "$path/$_"
358 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs; 651 for grep $_ !~ /^(?:CVS|dev|\..*)$/, @$dirs;
652
653 my $dir = $path;
654 substr $dir, 0, 1 + length $PATH, "";
359 655
360 for my $file (@$nondirs) { 656 for my $file (@$nondirs) {
657 if ($dir =~ /^music(?:\/|$)/) {
658 $c_res->put ([$path, $file, 3]) # FT_MUSIC
659 if $file =~ /\.(ogg)$/;
660
661 } elsif ($dir =~ /^sound(?:\/|$)/) {
662 $c_res->put ([$path, $file, 5]) # FT_SOUND
663 if $file =~ /\.(wav|ogg)$/;
664
665 } elsif ($dir =~ /^res(?:\/|$)/) {
666 if ($file =~ /\.(jpg|png)$/) {
667 $c_res->put ([$path, $file, 0]) # FT_FACE
668 } elsif ($file =~ /\.(res)$/) {
669 $c_res->put ([$path, $file, 6]) # FT_RSRC
670 } else {
671 $c_res->put ([$path, $file, undef]);
672 }
673
361 if ($file =~ /\.png$/) { 674 } elsif ($file =~ /\.png$/) {
362 push @png, ["$path/$file", 0]; 675 push @c_png, ["$path/$file", 0];
676
363 } elsif ($file =~ /\.trs$/) { 677 } elsif ($file =~ /\.trs$/) {
364 push @trs, [$path, $file]; 678 $c_trs->put ([$path, $file]);
679
365 } elsif ($file =~ /\.arc$/) { 680 } elsif ($file =~ /\.arc$/) {
366 push @arc, [$path, $file]; 681 $c_arc->put ([$path, $file]);
682
367 } else { 683 } else {
368 warn "ignoring $path/$file\n" if $VERBOSE >= 2; 684 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
369 } 685 }
370 } 686 }
371 }; 687 };
688 }
689
690 sub generate_plurals {
691# use Lingua::EN::Inflect ();
692# Lingua::EN::Inflect::classical;
693# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
694# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
695#
696# for my $a (@ARC) {
697# my $name = $a->{name} || $a->{_name};
698#
699# next unless $a->{name_pl};
700# next if $a->{invisible};
701# next if $a->{is_floor};
702# next if $a->{no_pick};
703#
704# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
705# my $pl = $test =~ /^(?:eq|p:.)$/
706# ? $name
707# : Lingua::EN::Inflect::PL $name;
708#
709# if ($pl ne $a->{name_pl}) {
710# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
711# }
712# }
372 } 713 }
373 714
374 sub inst_arch($) { 715 sub inst_arch($) {
375 my (undef, $path) = @_; 716 my (undef, $path) = @_;
376 717
718 $PATH = $path;
719
720 print "\n",
377 print "Installing '$path' to '$DATADIR'\n", 721 "Installing '$path' to '$DATADIR'\n",
722 "\n",
378 "This can take a long time if you run this\n", 723 "This can take a long time if you run this\n",
379 "for the first time or do not use --cache.\n", 724 "for the first time or do not use --cache.\n",
380 "\n", 725 "\n",
381 "Unless you run verbosely, all following warning\n", 726 "Unless you run verbosely, all following warning\n",
382 "or error messages indicate serious problems.\n", 727 "or error messages indicate serious problems.\n",
… …
385 if (!-d "$path/treasures") { 730 if (!-d "$path/treasures") {
386 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 731 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
387 exit 1 unless $FORCE; 732 exit 1 unless $FORCE;
388 } 733 }
389 734
735 print "scanning files...\n" if $VERBOSE;
736
390 find_files $path; 737 find_files $path;
738
739 my @a_arc = map +(async \&process_arc), 1..2;
740 my @a_res = map +(async \&process_res), 1..2;
741 my @a_trs = map +(async \&process_trs), 1..2;
742
391 IO::AIO::flush; 743 IO::AIO::flush;
392 744
393 $_->join for ( 745 $c_res->shutdown;
746 $c_arc->shutdown;
747 $c_trs->shutdown;
748
749 print "start file scan, arc, res processing...\n" if $VERBOSE;
750
751 $_->join for @a_arc; # need to parse all archetypes before png processing
752
753 print "end arc, start png processing...\n" if $VERBOSE;
754
394 # four png crunchers work fine for my 2x smp machine 755 # eight png crunchers work fine for my 4x smp machine
395 (async \&process_png), (async \&process_png), (async \&process_png), (async \&process_png), 756 my @a_png = map +(async \&process_png), 1..8;
396 (async \&process_trs), (async \&process_trs),
397 (async \&process_arc), (async \&process_arc),
398 );
399 757
758 $_->join for (@a_trs, @a_res, @a_png);
759
760 print "scanning done, processing results...\n" if $VERBOSE;
400 { 761 {
401 # remove path prefix from editor_folder 762 # remove path prefix from editor_folder
763 $_->{editor_folder} =~ /^\x00/
402 substr $_->{editor_folder}, 0, 1 + length $path, "" 764 and substr $_->{editor_folder}, 0, 2 + length $path, ""
403 for values %ARC; 765 for values %ARC;
404 766
767 print "resolving inheritance tree...\n" if $VERBOSE;
405 # resolve inherit 768 # resolve inherit
406 while () { 769 while () {
407 my $progress; 770 my $progress;
408 my $loop; 771 my $loop;
409 772
410 for my $o (values %ARC) { 773 for my $o (values %ARC) {
411 if (my $other = $o->{inherit}) { 774 for my $other (split /,/, $o->{inherit}) {
412 if (my $s = $ARC{$other}) { 775 if (my $s = $ARC{$other}) {
413 if ($s->{inherit}) { 776 if ($s->{inherit}) {
414 $loop = $s; 777 $loop = $s;
415 } else { 778 } else {
416 delete $o->{inherit}; 779 delete $o->{inherit};
780 my %s = %$s;
781 delete @s{qw(_name more name name_pl)};
417 %$o = ( %$s, %$o ); 782 %$o = ( %s, %$o );
418 ++$progress; 783 ++$progress;
419 } 784 }
420 } else { 785 } else {
421 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n"; 786 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
422 delete $ARC{$o->{_name}}; 787 delete $ARC{$o->{_name}};
… …
430 795
431 last; 796 last;
432 } 797 }
433 } 798 }
434 799
800 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
801 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC;
802
803 print "generating plurals...\n" if $VERBOSE;
804 generate_plurals;
805
806 printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
435 open my $fh, ">:utf8", "$DATADIR/archetypes~" 807 open my $fh, ">:utf8", "$DATADIR/archetypes~"
436 or die "$DATADIR/archetypes~: $!"; 808 or die "$DATADIR/archetypes~: $!";
437 print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } values %ARC]; 809 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
438 } 810 }
439 811
440 { 812 {
813 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
441 open my $fh, ">:utf8", "$DATADIR/treasures~" 814 open my $fh, ">:utf8", "$DATADIR/treasures~"
442 or die "$DATADIR/treasures~: $!"; 815 or die "$DATADIR/treasures~: $!";
443 print $fh $TRS; 816 print $fh $TRS;
444 } 817 }
445 818
446 { 819 {
820 print "processing facedata...\n" if $VERBOSE;
447 while (my ($k, $v) = each %FACEINFO) { 821 while (my ($k, $v) = each %FACEINFO) {
448 length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n"; 822 length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
449 length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n"; 823 length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
450 824
825 make_hash $k, $v->{data32}, $v->{hash32};
826 make_hash $k, $v->{data64}, $v->{hash64};
827
451 length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n"; 828 #length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";
452 #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n"; 829 #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
453 830
454 $v->{chksum32} = Digest::MD5::md5 $v->{data32}; 831 if (my $magicmap = $v->{magicmap}) {
455 $v->{chksum64} = Digest::MD5::md5 $v->{data64}; 832 $magicmap =~ y/A-Z_\-/a-z/d;
833 $v->{magicmap} = $COLOR{$magicmap};
456 } 834 }
835
836 my $stem = delete $v->{stem};
837 $v->{glyph} //= autoglyph $stem, $v;
838 utf8::encode $v->{glyph};
839 $v->{glyph} = (chr $v->{magicmap}) . $v->{glyph};
840
841 delete $v->{arc};
842 }
843
844 print "processing resources...\n" if $VERBOSE;
845 my $enc = JSON::XS->new->utf8->canonical->relaxed;
846 while (my ($k, $v) = each %RESOURCE) {
847
848 if ($v->{meta} && $v->{meta}{datadir}) {
849 delete $RESOURCE{$k};
850
851 $k =~ s/^res\/// or die "$k: datadir files must be in res/";
852
853 printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
854 open my $fh, ">:raw", "$DATADIR/$k~"
855 or die "$DATADIR/$k~: $!";
856 syswrite $fh, $v->{data};
857 push @COMMIT, $k;
858
859 } else {
860 if ($v->{type} & 1) {
861 # prepend meta info
862
863 my $meta = $enc->encode ({
864 name => $k,
865 %{ $v->{meta} || {} },
866 });
867
868 $v->{data} = pack "(w/a*)*", $meta, $v->{data};
869 }
870
871 make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
872 }
873 }
874
875 printf "writing facedata (%d faces, %d anims, %d resources)...\n",
876 scalar keys %FACEINFO,
877 scalar keys %ANIMINFO,
878 scalar keys %RESOURCE
879 if $VERBOSE;
457 880
458 open my $fh, ">:perlio", "$DATADIR/facedata~" 881 open my $fh, ">:perlio", "$DATADIR/facedata~"
459 or die "$DATADIR/facedata~: $!"; 882 or die "$DATADIR/facedata~: $!";
460 883
461 print $fh freeze { 884 print $fh nfreeze {
462 version => 2, 885 version => 2,
463 faceinfo => \%FACEINFO, 886 faceinfo => \%FACEINFO,
464 animinfo => \%ANIMINFO, 887 animinfo => \%ANIMINFO,
888 resource => \%RESOURCE,
465 }; 889 };
466 }
467 890
891 }
892
893 print "committing files...\n" if $VERBOSE;
894
468 for (qw(archetypes facedata treasures)) { 895 for (qw(archetypes facedata treasures), @COMMIT) {
469 chmod 0644, "$DATADIR/$_~"; 896 chmod 0644, "$DATADIR/$_~";
470 rename "$DATADIR/$_~", "$DATADIR/$_" 897 rename "$DATADIR/$_~", "$DATADIR/$_"
471 or die "$DATADIR/$_: $!"; 898 or die "$DATADIR/$_: $!";
472 } 899 }
473 900

Diff Legend

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