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.88 by root, Tue Oct 5 23:26:44 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 # hahs collinion, 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
161sub autoglyph {
162 my ($stem, $face) = @_;
163
164 if ($stem =~ /^wall\/|Nimwall/) {
165# warn $stem;
166 "+"
167 } elsif ($stem =~ /^floor\/|^ground\/|Nimfloor/) {
168 "."
169 } elsif ($stem =~ /^player\//) {
170 "@"
171 } else {
172 substr $stem, 0, 1
173 }
84} 174}
85 175
86{ 176{
87 our %ANIMINFO; 177 our %ANIMINFO;
88 our %FACEINFO; 178 our %FACEINFO;
179 our %RESOURCE;
180 our @ARC;
89 our %ARC; 181 our %ARC;
90 our $TRS; 182 our $TRS;
91 our $NFILE; 183 our $NFILE;
184 our $PATH;
92 185
93 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 186 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
94 187
95 our (@png, @trs, @arc); # files we are interested in 188 our $c_arc = new Coro::Channel;
189 our $c_trs = new Coro::Channel;
190 our $c_res = new Coro::Channel;
96 191
192 our @c_png;
193
97 sub commit_png($$$) { 194 sub commit_png($$$$) {
98 my ($name, $data, $T) = @_; 195 my ($stem, $name, $data, $T) = @_;
99 196
197 $FACEINFO{$name}{"stem"} = substr $stem, 1 + length $PATH;
100 $FACEINFO{$name}{"data$T"} = $data; 198 $FACEINFO{$name}{"data$T"} = $data;
101 } 199 }
102 200
103 sub process_png { 201 sub process_png {
104 while (@png) { 202 while (@c_png) {
105 my ($path, $delete) = @{pop @png}; 203 my ($path, $delete) = @{pop @c_png};
106 204
107 my $png; 205 my $png;
108 aio_lstat $path; 206 aio_lstat $path;
109 my ($size, $mtime) = (stat _)[7,9]; 207 my ($size, $mtime) = (stat _)[7,9];
110 208
… …
141 if ($w % $T || $h % $T) { 239 if ($w % $T || $h % $T) {
142 warn "$path: weird png size ($w $h), skipping.\n"; 240 warn "$path: weird png size ($w $h), skipping.\n";
143 next; 241 next;
144 } 242 }
145 243
244 (my $base = $stem) =~ s/^.*\///;
245
246 my $fi = $FACEINFO{$base};
247 unless ($fi) {
248 #warn "$path: <$base> not referenced by any archetype, skipping.\n";
249 #next;
250 }
251
252 my $arc = $fi->{arc} || { };
253
146 unless ($path =~ /~$/) { 254 unless ($path =~ /~$/) {
147 # possibly enlarge 255 # possibly enlarge
148 if (0 > aio_stat "$stem.64x64.png") { 256 if (0 > aio_stat "$stem.64x64.png") {
149 my $other = "$stem.64x64.png~"; 257 my $other = "$stem.64x64.png~";
150 258
151 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 259 if (0 > aio_lstat $other or (-M _) > (-M $path)) {
152 my $wrap = 0; # for the time being
153 fork_sub { 260 fork_sub {
261 my $CROP;
262 my $SRC = "png:\Q$path\E";
263
264 my $is_floor = $arc->{is_floor};
265 my $is_wall = 0;
266
267 my ($wall_pfx, $wall_dir, $wall_sfx);
268
269 if (
270 !$is_floor
271 && !$arc->{alive}
272 && $arc->{move_block} eq "all"
273 && $path =~ /^(.*_)([0-9A-F])(\.x11.*\.png)$/
274 ) {
275 ($wall_pfx, $wall_dir, $wall_sfx) = ($1, hex $2, $3);
276
277 unless (grep { !-e sprintf "%s%X%s", $wall_pfx, $_, $wall_sfx } 0..15) {
278 $is_wall = 1;
279 }
280 }
281
282 if ($is_wall || $is_floor) {
283 # add a 4px border and add other images around it
284 $CROP = "-shave 8x8 +repage";
285
286 $w += 8;
287 $h += 8;
288
289 $SRC = "-size ${w}x${h} xc:transparent";
290 $SRC .= " png:\Q$path\E -geometry +4+4 -composite";
291
292 # 8 surrounding images
293 for (
294 # x y b r0 r1
295 [-1, -1, 0, 6],
296 [ 0, -1, 1, 10, 14],
297 [+1, -1, 0, 12],
298
299 [-1, 0, 8, 5, 7],
300 #
301 [+1, 0, 2, 5, 13],
302
303 [-1, +1, 0, 3],
304 [ 0, +1, 4, 10, 11],
305 [+1, +1, 0, 9],
306 ) {
307 my ($x, $y, $d, $r0, $r1) = @$_;
308
309 my $tile = $is_floor ? $path
310 : $is_wall ? sprintf "%s%X%s", $wall_pfx, ($wall_dir & $d) ? $r1 : $r0, $wall_sfx
311 : die;
312
313 $SRC .= sprintf " png:%s -geometry %+d%+d -composite",
314 "\Q$tile",
315 $x * ($w - 8) + 4,
316 $y * ($h - 8) + 4;
317 }
318 }
319
154 system "convert png:\Q$path\E -depth 8 rgba:-" 320 system "convert -depth 8 $SRC rgba:-"
155 . "| $exec_prefix/bin/cfhq2xa $w $h $wrap" 321 . "| $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~" 322 . "| 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 $? ($!)"; 323 and die "convert/cfhq2xa pipeline error: status $? ($!)";
158 system $OPTIPNG, "-o5", "-i0", "-q", "$other~"; 324 system $OPTIPNG, "-i0", "-q", "$other~";
159 die "$other~ has zero size, aborting." unless -s "$other~"; 325 die "$other~ has zero size, aborting." unless -s "$other~";
160 rename "$other~", $other; 326 rename "$other~", $other;
161 }; 327 };
162 } 328 }
163 329
164 push @png, [$other, !$CACHE]; 330 push @c_png, [$other, !$CACHE];
165 } 331 }
166 332
167 # possibly scale down 333 # possibly scale down
168 if (0 > aio_stat "$stem.32x32.png") { 334 if (0 > aio_stat "$stem.32x32.png") {
169 my $other = "$stem.32x32.png~"; 335 my $other = "$stem.32x32.png~";
170 336
171 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 337 if (0 > aio_lstat $other or (-M _) > (-M $path)) {
172 fork_sub { 338 fork_sub {
173 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~"; 339 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
174 system $OPTIPNG, "-o5", "-i0", "-q", "$other~"; 340 system $OPTIPNG, "-i0", "-q", "$other~";
341
342 # reduce smoothfaces >10000 bytes
343 # obsolete, no longer required
344 if (0 && $stem =~ /_S\./ && (-s "$other~") > 10000) {
345 my $ncolor = 256;
346 while () {
347 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
348 system $OPTIPNG, "-i0", "-q", "$other~~";
349 last if 10000 > -s "$other~~";
350 $ncolor = int $ncolor * 0.9;
351 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
352 }
353
354 printf "reduced %s from %d to %d bytes using %d colours.\n",
355 $other, -s "$other~", -s "$other~~", $ncolor
356 if $VERBOSE >= 2;
357 rename "$other~~", "$other~";
358 }
359
175 die "$other~ has zero size, aborting." unless -s "$other~"; 360 die "$other~ has zero size, aborting." unless -s "$other~";
176 rename "$other~", $other; 361 rename "$other~", $other;
177 }; 362 };
178 } 363 }
179 364
180 #warn "scaled down $path to $other\n";#d# 365 #warn "scaled down $path to $other\n";#d#
181 push @png, [$other, !$CACHE]; 366 push @c_png, [$other, !$CACHE];
182 } 367 }
183 } 368 }
184 369
185 (my $face = $stem) =~ s/^.*\///; 370 (my $face = $stem) =~ s/^.*\///;
186 371
… …
235 420
236 if (0 > aio_load $file, $tile) { 421 if (0 > aio_load $file, $tile) {
237 die "$path: unable to read tile +$x+$y, aborting.\n"; 422 die "$path: unable to read tile +$x+$y, aborting.\n";
238 } 423 }
239 IO::AIO::aio_unlink $file unless $CACHE; 424 IO::AIO::aio_unlink $file unless $CACHE;
240 commit_png $x|$y ? "$face+$x+$y" : $face, $tile, $T; 425 commit_png $stem, $x|$y ? "$face+$x+$y" : $face, $tile, $T;
241 } 426 }
242 } else { 427 } else {
243 # use as-is (either small, use smooth) 428 # use as-is (either small, use smooth)
244 commit_png $face, $png, $T; 429 commit_png $stem, $face, $png, $T;
245 } 430 }
246 431
247 aio_unlink $path if $delete; 432 aio_unlink $path if $delete;
248 } 433 }
249 } 434 }
250 435
251 sub process_arc { 436 sub process_arc {
252 while (@arc) { 437 while (my $job = $c_arc->get) {
253 my ($dir, $file) = @{pop @arc}; 438 my ($dir, $file) = @$job;
254 439
255 my $arc; 440 my $arc;
256 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/ 441 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
257 442
258 my $arc = read_arch "$dir/$file"; 443 my $arc = read_arch "$dir/$file";
259 for my $o (values %$arc) { 444 for my $o (values %$arc) {
445 push @ARC, $o;
446 for (my $m = $o; $m; $m = $m->{more}) {
260 $ARC{$o->{_name}} = $o; 447 $ARC{$m->{_name}} = $m;
448 }
261 449
262 $o->{editor_folder} = $dir; 450 $o->{editor_folder} ||= "\x00$dir"; # horrible kludge
263 451
264 my $visibility = delete $o->{visibility}; 452 my $visibility = delete $o->{visibility};
265 my $magicmap = delete $o->{magicmap}; 453 my $magicmap = delete $o->{magicmap};
454 my $glyph = delete $o->{glyph};
266 455
267 # find upper left corner :/ 456 # find upper left corner :/
268 # omg, this is sooo broken 457 # omg, this is sooo broken
269 my ($dx, $dy); 458 my ($dx, $dy);
270 for (my $o = $o; $o; $o = $o->{more}) { 459 for (my $o = $o; $o; $o = $o->{more}) {
… …
278 467
279 my $ext = $x|$y ? "+$x+$y" : ""; 468 my $ext = $x|$y ? "+$x+$y" : "";
280 469
281 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face}; 470 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face};
282 471
283 my $visibility = delete $o->{visibility} if exists $o->{visibility}; 472 $visibility = delete $o->{visibility} if exists $o->{visibility};
284 my $magicmap = delete $o->{magicmap} if exists $o->{magicmap}; 473 $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
474 $glyph = delete $o->{glyph} if exists $o->{glyph};
285 475
286 my $anim = delete $o->{anim}; 476 my $anim = delete $o->{anim};
287 477
288 if ($anim) { 478 if ($anim) {
289 # possibly add $ext to the animation name to avoid 479 # possibly add $ext to the animation name to avoid
… …
307 facings => $facings, 497 facings => $facings,
308 frames => \@frames, 498 frames => \@frames,
309 }; 499 };
310 } 500 }
311 501
312 for my $face ($o->{face} || (), @{$anim || []}) { 502 for ($o->{face} || (), @{$anim || []}) {
313 next if $face =~ /^facings\s|^blank.x11$|^empty.x11$/; 503 next if /^facings\s/;
314 504
505 my $face = $_;
506 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
507
315 my $info = $FACEINFO{$face} ||= {}; 508 my $info = $FACEINFO{$face} ||= { };
509 $info->{arc} = $o;
510
511 next if $face =~ /^blank.x11$|^empty.x11$/;
316 512
317 $info->{visibility} = $visibility if defined $visibility; 513 $info->{visibility} = $visibility if defined $visibility;
318 $info->{magicmap} = $magicmap if defined $magicmap; 514 $info->{magicmap} = $magicmap if defined $magicmap;
515 $info->{glyph} = $glyph if defined $glyph;
319 } 516 }
320 517
321 if (my $smooth = delete $o->{smoothface}) { 518 if (my $smooth = delete $o->{smoothface}) {
322 my %kv =split /\s+/, $smooth; 519 my %kv = split /\s+/, $smooth;
323 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 520 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
324 while (my ($face, $smooth) = each %kv) { 521 while (my ($face, $smooth) = each %kv) {
522 $FACEINFO{$smooth}{arc} = $o;
523
325 $FACEINFO{$face}{smooth} = $smooth; 524 $FACEINFO{$face}{smooth} = $smooth;
326 $FACEINFO{$face}{smoothlevel} = $level; 525 $FACEINFO{$face}{smoothlevel} = $level;
327 } 526 }
328 } 527 }
329 } 528 }
330 } 529 }
331 } 530 }
332 } 531 }
333 532
334 sub process_trs { 533 sub process_trs {
335 while (@trs) { 534 while (my $job = $c_trs->get) {
336 my ($dir, $file) = @{pop @trs}; 535 my ($dir, $file) = @$job;
337 my $path = "$dir/$file"; 536 my $path = "$dir/$file";
338 537
339 my $trs; 538 my $trs;
340 if (0 > aio_load $path, $trs) { 539 if (0 > aio_load $path, $trs) {
341 warn "$path: $!, skipping.\n"; 540 warn "$path: $!, skipping.\n";
… …
344 543
345 $TRS .= $trs; 544 $TRS .= $trs;
346 } 545 }
347 } 546 }
348 547
548 my %FILECACHE;
549
550 sub load_cached($;$) {
551 unless (exists $FILECACHE{$_[0]}) {
552 my $data;
553 if (0 < aio_load $_[0], $data) {
554 if ($_[1]) {
555 $data = eval { $_[1]->($data) };
556 warn "$_[0]: $@" if $@;
557 }
558 }
559
560 $FILECACHE{$_[0]} = $data;
561 }
562
563 $FILECACHE{$_[0]}
564 }
565
566 sub process_res {
567 while (my $job = $c_res->get) {
568 my ($dir, $file, $type) = @$job;
569
570 my $data;
571 aio_load "$dir/$file", $data;
572
573 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
574
575 utf8::decode $dir;
576 utf8::decode $file;
577
578 # a meta file for resources is now mandatory
579 unless (exists $meta->{$file}) {
580 warn "skipping $dir/$file\n" if $VERBOSE >= 3;
581 next;
582 }
583
584 $meta = {
585 %{ $meta->{"" } || {} },
586 %{ $meta->{$file} || {} },
587 };
588
589 if ($meta->{license} =~ s/^#//) {
590 $meta->{license} = ({
591 "pd" => "Public Domain",
592 "gpl" => "GNU General Public License, version 3.0 or any later",
593 "cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
594 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
595 "cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
596 "cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
597 })->{$meta->{license}}
598 || warn "$dir/$file: license tag '$meta->{license}' not found.";
599 }
600
601 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
602 ($meta->{author} = $1) =~ s/_/ /g;
603 }
604
605 $file =~ s/\.res$//;
606 $file =~ s/\.(ogg|wav|jpg|png)$//;
607
608 substr $dir, 0, 1 + length $PATH, "";
609
610 if (my $filter = $meta->{cfutil_filter}) {
611 if ($filter eq "yaml2json") {
612 $data = JSON::XS::encode_json YAML::XS::Load $data;
613 } elsif ($filter eq "json2json") {
614 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
615 } elsif ($filter eq "perl2json") {
616 $data = eval $data; die if $@;
617 $data = JSON::XS::encode_json $data;
618 } else {
619 warn "$dir/$file: unknown filter $filter, skipping\n";
620 }
621 }
622
623 $RESOURCE{"$dir/$file"} = {
624 type => (exists $meta->{type} ? delete $meta->{type} : $type),
625 data => $data,
626 %$meta ? (meta => $meta) : (),
627 };
628 }
629 }
630
349 sub find_files; 631 sub find_files;
350 sub find_files { 632 sub find_files {
351 my ($path) = @_; 633 my ($path) = @_;
352 634
353 IO::AIO::aioreq_pri 4; 635 IO::AIO::aioreq_pri 4;
354 IO::AIO::aio_scandir $path, 4, sub { 636 IO::AIO::aio_scandir $path, 4, sub {
355 my ($dirs, $nondirs) = @_; 637 my ($dirs, $nondirs) = @_;
356 638
357 find_files "$path/$_" 639 find_files "$path/$_"
358 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs; 640 for grep $_ !~ /^(?:CVS|dev|\..*)$/, @$dirs;
641
642 my $dir = $path;
643 substr $dir, 0, 1 + length $PATH, "";
359 644
360 for my $file (@$nondirs) { 645 for my $file (@$nondirs) {
646 if ($dir =~ /^music(?:\/|$)/) {
647 $c_res->put ([$path, $file, 3]) # FT_MUSIC
648 if $file =~ /\.(ogg)$/;
649
650 } elsif ($dir =~ /^sound(?:\/|$)/) {
651 $c_res->put ([$path, $file, 5]) # FT_SOUND
652 if $file =~ /\.(wav|ogg)$/;
653
654 } elsif ($dir =~ /^res(?:\/|$)/) {
655 if ($file =~ /\.(jpg|png)$/) {
656 $c_res->put ([$path, $file, 0]) # FT_FACE
657 } elsif ($file =~ /\.(res)$/) {
658 $c_res->put ([$path, $file, 6]) # FT_RSRC
659 } else {
660 $c_res->put ([$path, $file, undef]);
661 }
662
361 if ($file =~ /\.png$/) { 663 } elsif ($file =~ /\.png$/) {
362 push @png, ["$path/$file", 0]; 664 push @c_png, ["$path/$file", 0];
665
363 } elsif ($file =~ /\.trs$/) { 666 } elsif ($file =~ /\.trs$/) {
364 push @trs, [$path, $file]; 667 $c_trs->put ([$path, $file]);
668
365 } elsif ($file =~ /\.arc$/) { 669 } elsif ($file =~ /\.arc$/) {
366 push @arc, [$path, $file]; 670 $c_arc->put ([$path, $file]);
671
367 } else { 672 } else {
368 warn "ignoring $path/$file\n" if $VERBOSE >= 2; 673 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
369 } 674 }
370 } 675 }
371 }; 676 };
677 }
678
679 sub generate_plurals {
680# use Lingua::EN::Inflect ();
681# Lingua::EN::Inflect::classical;
682# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
683# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
684#
685# for my $a (@ARC) {
686# my $name = $a->{name} || $a->{_name};
687#
688# next unless $a->{name_pl};
689# next if $a->{invisible};
690# next if $a->{is_floor};
691# next if $a->{no_pick};
692#
693# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
694# my $pl = $test =~ /^(?:eq|p:.)$/
695# ? $name
696# : Lingua::EN::Inflect::PL $name;
697#
698# if ($pl ne $a->{name_pl}) {
699# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
700# }
701# }
372 } 702 }
373 703
374 sub inst_arch($) { 704 sub inst_arch($) {
375 my (undef, $path) = @_; 705 my (undef, $path) = @_;
376 706
707 $PATH = $path;
708
709 print "\n",
377 print "Installing '$path' to '$DATADIR'\n", 710 "Installing '$path' to '$DATADIR'\n",
711 "\n",
378 "This can take a long time if you run this\n", 712 "This can take a long time if you run this\n",
379 "for the first time or do not use --cache.\n", 713 "for the first time or do not use --cache.\n",
380 "\n", 714 "\n",
381 "Unless you run verbosely, all following warning\n", 715 "Unless you run verbosely, all following warning\n",
382 "or error messages indicate serious problems.\n", 716 "or error messages indicate serious problems.\n",
… …
385 if (!-d "$path/treasures") { 719 if (!-d "$path/treasures") {
386 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 720 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
387 exit 1 unless $FORCE; 721 exit 1 unless $FORCE;
388 } 722 }
389 723
724 print "scanning files...\n" if $VERBOSE;
725
390 find_files $path; 726 find_files $path;
727
728 my @a_arc = map +(async \&process_arc), 1..2;
729 my @a_res = map +(async \&process_res), 1..2;
730 my @a_trs = map +(async \&process_trs), 1..2;
731
391 IO::AIO::flush; 732 IO::AIO::flush;
392 733
393 $_->join for ( 734 $c_res->shutdown;
735 $c_arc->shutdown;
736 $c_trs->shutdown;
737
738 print "start file scan, arc, res processing...\n" if $VERBOSE;
739
740 $_->join for @a_arc; # need to parse all archetypes before png processing
741
742 print "end arc, start png processing...\n" if $VERBOSE;
743
394 # four png crunchers work fine for my 2x smp machine 744 # eight png crunchers work fine for my 4x smp machine
395 (async \&process_png), (async \&process_png), (async \&process_png), (async \&process_png), 745 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 746
747 $_->join for (@a_trs, @a_res, @a_png);
748
749 print "scanning done, processing results...\n" if $VERBOSE;
400 { 750 {
401 # remove path prefix from editor_folder 751 # remove path prefix from editor_folder
752 $_->{editor_folder} =~ /^\x00/
402 substr $_->{editor_folder}, 0, 1 + length $path, "" 753 and substr $_->{editor_folder}, 0, 2 + length $path, ""
403 for values %ARC; 754 for values %ARC;
404 755
756 print "resolving inheritance tree...\n" if $VERBOSE;
405 # resolve inherit 757 # resolve inherit
406 while () { 758 while () {
407 my $progress; 759 my $progress;
408 my $loop; 760 my $loop;
409 761
410 for my $o (values %ARC) { 762 for my $o (values %ARC) {
411 if (my $other = $o->{inherit}) { 763 for my $other (split /,/, $o->{inherit}) {
412 if (my $s = $ARC{$other}) { 764 if (my $s = $ARC{$other}) {
413 if ($s->{inherit}) { 765 if ($s->{inherit}) {
414 $loop = $s; 766 $loop = $s;
415 } else { 767 } else {
416 delete $o->{inherit}; 768 delete $o->{inherit};
769 my %s = %$s;
770 delete @s{qw(_name more name name_pl)};
417 %$o = ( %$s, %$o ); 771 %$o = ( %s, %$o );
418 ++$progress; 772 ++$progress;
419 } 773 }
420 } else { 774 } else {
421 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n"; 775 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
422 delete $ARC{$o->{_name}}; 776 delete $ARC{$o->{_name}};
… …
430 784
431 last; 785 last;
432 } 786 }
433 } 787 }
434 788
789 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
790 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC;
791
792 print "generating plurals...\n" if $VERBOSE;
793 generate_plurals;
794
795 printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
435 open my $fh, ">:utf8", "$DATADIR/archetypes~" 796 open my $fh, ">:utf8", "$DATADIR/archetypes~"
436 or die "$DATADIR/archetypes~: $!"; 797 or die "$DATADIR/archetypes~: $!";
437 print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } values %ARC]; 798 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
438 } 799 }
439 800
440 { 801 {
802 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
441 open my $fh, ">:utf8", "$DATADIR/treasures~" 803 open my $fh, ">:utf8", "$DATADIR/treasures~"
442 or die "$DATADIR/treasures~: $!"; 804 or die "$DATADIR/treasures~: $!";
443 print $fh $TRS; 805 print $fh $TRS;
444 } 806 }
445 807
446 { 808 {
809 print "processing facedata...\n" if $VERBOSE;
447 while (my ($k, $v) = each %FACEINFO) { 810 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"; 811 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"; 812 length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
450 813
814 make_hash $k, $v->{data32}, $v->{hash32};
815 make_hash $k, $v->{data64}, $v->{hash64};
816
451 length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n"; 817 #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"; 818 #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
453 819
454 $v->{chksum32} = Digest::MD5::md5 $v->{data32}; 820 my $stem = delete $v->{stem};
455 $v->{chksum64} = Digest::MD5::md5 $v->{data64}; 821 $v->{glyph} //= autoglyph $stem, $v;
822
823 if (my $magicmap = $v->{magicmap}) {
824 $magicmap =~ y/A-Z_\-/a-z/d;
825 $v->{magicmap} = $COLOR{$magicmap};
456 } 826 }
827
828 delete $v->{arc};
829 }
830
831 print "processing resources...\n" if $VERBOSE;
832 my $enc = JSON::XS->new->utf8->canonical->relaxed;
833 while (my ($k, $v) = each %RESOURCE) {
834
835 if ($v->{meta} && $v->{meta}{datadir}) {
836 delete $RESOURCE{$k};
837
838 $k =~ s/^res\/// or die "$k: datadir files must be in res/";
839
840 printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
841 open my $fh, ">:raw", "$DATADIR/$k~"
842 or die "$DATADIR/$k~: $!";
843 syswrite $fh, $v->{data};
844 push @COMMIT, $k;
845
846 } else {
847 if ($v->{type} & 1) {
848 # prepend meta info
849
850 my $meta = $enc->encode ({
851 name => $k,
852 %{ $v->{meta} || {} },
853 });
854
855 $v->{data} = pack "(w/a*)*", $meta, $v->{data};
856 }
857
858 make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
859 }
860 }
861
862 printf "writing facedata (%d faces, %d anims, %d resources)...\n",
863 scalar keys %FACEINFO,
864 scalar keys %ANIMINFO,
865 scalar keys %RESOURCE
866 if $VERBOSE;
457 867
458 open my $fh, ">:perlio", "$DATADIR/facedata~" 868 open my $fh, ">:perlio", "$DATADIR/facedata~"
459 or die "$DATADIR/facedata~: $!"; 869 or die "$DATADIR/facedata~: $!";
460 870
461 print $fh freeze { 871 print $fh nfreeze {
462 version => 2, 872 version => 2,
463 faceinfo => \%FACEINFO, 873 faceinfo => \%FACEINFO,
464 animinfo => \%ANIMINFO, 874 animinfo => \%ANIMINFO,
875 resource => \%RESOURCE,
465 }; 876 };
466 }
467 877
878 }
879
880 print "committing files...\n" if $VERBOSE;
881
468 for (qw(archetypes facedata treasures)) { 882 for (qw(archetypes facedata treasures), @COMMIT) {
469 chmod 0644, "$DATADIR/$_~"; 883 chmod 0644, "$DATADIR/$_~";
470 rename "$DATADIR/$_~", "$DATADIR/$_" 884 rename "$DATADIR/$_~", "$DATADIR/$_"
471 or die "$DATADIR/$_: $!"; 885 or die "$DATADIR/$_: $!";
472 } 886 }
473 887

Diff Legend

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