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.81 by root, Sat Apr 3 03:13:48 2010 UTC

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

Diff Legend

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