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

Diff Legend

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