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.73 by root, Mon Oct 26 11:31:39 2009 UTC

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

Diff Legend

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