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

Diff Legend

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