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

Diff Legend

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