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.107 by root, Wed Oct 20 06:36: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 die "glyph $face too long" if 2 < length $glyph;
461
462 $fi->{glyph} = "";
463 for (split //, $glyph) {
464 utf8::encode $_;
465 $fi->{glyph} .= (chr $fgi) . (chr $bgi) . $_;
466 }
467 }
468 }
469
251 sub process_arc { 470 sub process_arc {
252 while (@arc) { 471 while (my ($dir, $file) = @{ $c_arc->get }) {
253 my ($dir, $file) = @{pop @arc};
254
255 my $arc; 472 my $arc;
256 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/ 473 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
257 474
258 my $arc = read_arch "$dir/$file"; 475 my $arc = read_arch "$dir/$file";
259 for my $o (values %$arc) { 476 for my $o (values %$arc) {
477 push @ARC, $o;
478 for (my $m = $o; $m; $m = $m->{more}) {
260 $ARC{$o->{_name}} = $o; 479 $ARC{$m->{_name}} = $m;
480 }
261 481
262 $o->{editor_folder} = $dir; 482 $o->{editor_folder} ||= "\x00$dir"; # horrible kludge
263
264 my $visibility = delete $o->{visibility};
265 my $magicmap = delete $o->{magicmap};
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}) {
277 my $y = $o->{y} - $dy; 494 my $y = $o->{y} - $dy;
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
283 my $visibility = delete $o->{visibility} if exists $o->{visibility};
284 my $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
285 499
286 my $anim = delete $o->{anim}; 500 my $anim = delete $o->{anim};
287 501
288 if ($anim) { 502 if ($anim) {
289 # possibly add $ext to the animation name to avoid 503 # possibly add $ext to the animation name to avoid
307 facings => $facings, 521 facings => $facings,
308 frames => \@frames, 522 frames => \@frames,
309 }; 523 };
310 } 524 }
311 525
312 for my $face ($o->{face} || (), @{$anim || []}) { 526 for ($o->{face} || (), @{$anim || []}) {
313 next if $face =~ /^facings\s|^blank.x11$|^empty.x11$/; 527 next if /^facings\s/;
314 528
529 my $face = $_;
530 $face =~ s/\+\d+\+\d+$//; # remove tile offset coordinates
531
315 my $info = $FACEINFO{$face} ||= {}; 532 my $info = $FACEINFO{$face} ||= { };
533 $info->{arc} = $o;
316 534
317 $info->{visibility} = $visibility if defined $visibility; 535 next if $face =~ /^blank.x11$|^empty.x11$/;
318 $info->{magicmap} = $magicmap if defined $magicmap;
319 } 536 }
320 537
321 if (my $smooth = delete $o->{smoothface}) { 538 if (my $smooth = delete $o->{smoothface}) {
322 my %kv =split /\s+/, $smooth; 539 my %kv = split /\s+/, $smooth;
323 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 540 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
324 while (my ($face, $smooth) = each %kv) { 541 while (my ($face, $smooth) = each %kv) {
542 $FACEINFO{$smooth}{arc} = $o;
543
325 $FACEINFO{$face}{smooth} = $smooth; 544 $FACEINFO{$face}{smooth} = $smooth;
326 $FACEINFO{$face}{smoothlevel} = $level; 545 $FACEINFO{$face}{smoothlevel} = $level;
327 } 546 }
328 } 547 }
329 } 548 }
330 } 549 }
331 } 550 }
332 } 551 }
333 552
334 sub process_trs { 553 sub process_trs {
335 while (@trs) {
336 my ($dir, $file) = @{pop @trs}; 554 my ($dir, $file) = @_;
337 my $path = "$dir/$file"; 555 my $path = "$dir/$file";
338 556
339 my $trs; 557 my $trs;
340 if (0 > aio_load $path, $trs) { 558 if (0 > aio_load $path, $trs) {
341 warn "$path: $!, skipping.\n"; 559 warn "$path: $!, skipping.\n";
342 next; 560 return;
343 } 561 }
344 562
345 $TRS .= $trs; 563 $TRS .= $trs;
564 }
565
566 my %FILECACHE;
567
568 sub load_cached($;$) {
569 unless (exists $FILECACHE{$_[0]}) {
570 my $data;
571 if (0 < aio_load $_[0], $data) {
572 if ($_[1]) {
573 $data = eval { $_[1]->($data) };
574 warn "$_[0]: $@" if $@;
575 }
576 }
577
578 $FILECACHE{$_[0]} = $data;
579 }
580
581 $FILECACHE{$_[0]}
582 }
583
584 sub process_res {
585 my ($dir, $file, $type) = @_;
586
587 my $data;
588 aio_load "$dir/$file", $data;
589
590 my $meta = load_cached "$dir/meta", sub { JSON::XS->new->utf8->relaxed->decode (shift) };
591
592 utf8::decode $dir;
593 utf8::decode $file;
594
595 # a meta file for resources is now mandatory
596 unless (exists $meta->{$file}) {
597 warn "skipping $dir/$file\n" if $VERBOSE >= 3;
598 return;
599 }
600
601 $meta = {
602 %{ $meta->{"" } || {} },
603 %{ $meta->{$file} || {} },
604 };
605
606 if ($meta->{license} =~ s/^#//) {
607 $meta->{license} = ({
608 "pd" => "Public Domain",
609 "gpl" => "GNU General Public License, version 3.0 or any later",
610 "cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
611 "cc/by/2.1" => "Licensed under Creative Commons Attribution 2.1 http://creativecommons.org/licenses/by/2.1/",
612 "cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
613 "cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
614 })->{$meta->{license}}
615 || warn "$dir/$file: license tag '$meta->{license}' not found.";
616 }
617
618 if (!exists $meta->{author} && $meta->{source} =~ m%^http://www.jamendo.com/en/artist/(.*)$%) {
619 ($meta->{author} = $1) =~ s/_/ /g;
620 }
621
622 $file =~ s/\.res$//;
623 $file =~ s/\.(ogg|wav|jpg|png)$//;
624
625 substr $dir, 0, 1 + length $PATH, "";
626
627 if (my $filter = $meta->{cfutil_filter}) {
628 if ($filter eq "yaml2json") {
629 $data = JSON::XS::encode_json YAML::XS::Load $data;
630 } elsif ($filter eq "json2json") {
631 $data = JSON::XS::encode_json JSON::XS->relaxed->utf8->decode ($data);
632 } elsif ($filter eq "perl2json") {
633 $data = eval $data; die if $@;
634 $data = JSON::XS::encode_json $data;
635 } else {
636 warn "$dir/$file: unknown filter $filter, skipping\n";
637 }
638 }
639
640 $RESOURCE{"$dir/$file"} = {
641 type => (exists $meta->{type} ? delete $meta->{type} : $type),
642 data => $data,
643 %$meta ? (meta => $meta) : (),
644 };
645 }
646
647 sub process_any {
648 while (my ($func, @args) = @{ $c_any->get }) {
649 $func->(@args);
346 } 650 }
347 } 651 }
348 652
349 sub find_files; 653 sub find_files;
350 sub find_files { 654 sub find_files {
351 my ($path) = @_; 655 my ($path) = @_;
352 656
657 my $grp = IO::AIO::aio_group;
658
659 my $scandir; $scandir = sub {
660 my ($path) = @_;
661
353 IO::AIO::aioreq_pri 4; 662 IO::AIO::aioreq_pri 4;
354 IO::AIO::aio_scandir $path, 4, sub { 663 add $grp IO::AIO::aio_scandir $path, 4, sub {
355 my ($dirs, $nondirs) = @_; 664 my ($dirs, $nondirs) = @_;
356 665
357 find_files "$path/$_" 666 $scandir->("$path/$_")
358 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs; 667 for grep $_ !~ /^(?:CVS|dev|\..*)$/, @$dirs;
359 668
669 my $dir = $path;
670 substr $dir, 0, 1 + length $PATH, "";
671
360 for my $file (@$nondirs) { 672 for my $file (@$nondirs) {
673 if ($dir =~ /^music(?:\/|$)/) {
674 $c_any->put ([\&process_res, $path, $file, 3]) # FT_MUSIC
675 if $file =~ /\.(ogg)$/;
676
677 } elsif ($dir =~ /^sound(?:\/|$)/) {
678 $c_any->put ([\&process_res, $path, $file, 5]) # FT_SOUND
679 if $file =~ /\.(wav|ogg)$/;
680
681 } elsif ($dir =~ /^res(?:\/|$)/) {
682 if ($file =~ /\.(jpg|png)$/) {
683 $c_any->put ([\&process_res, $path, $file, 0]) # FT_FACE
684 } elsif ($file =~ /\.(res)$/) {
685 $c_any->put ([\&process_res, $path, $file, 6]) # FT_RSRC
686 } else {
687 $c_any->put ([\&process_res, $path, $file, undef]);
688 }
689
361 if ($file =~ /\.png$/) { 690 } elsif ($file =~ /\.png$/) {
362 push @png, ["$path/$file", 0]; 691 push @c_png, ["$path/$file", 0];
692
693 } elsif ($file =~ /\.faceinfo$/) {
694 $c_any->put ([\&process_faceinfo, $path, $file]);
695
363 } elsif ($file =~ /\.trs$/) { 696 } elsif ($file =~ /\.trs$/) {
364 push @trs, [$path, $file]; 697 $c_any->put ([\&process_trs, $path, $file]);
698
365 } elsif ($file =~ /\.arc$/) { 699 } elsif ($file =~ /\.arc$/) {
366 push @arc, [$path, $file]; 700 $c_arc->put ([$path, $file]);
701
367 } else { 702 } else {
368 warn "ignoring $path/$file\n" if $VERBOSE >= 2; 703 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
369 } 704 }
705 }
370 } 706 };
371 }; 707 };
708
709 $scandir->($path);
710 aio_wait $grp;
711 }
712
713 sub generate_plurals {
714# use Lingua::EN::Inflect ();
715# Lingua::EN::Inflect::classical;
716# Lingua::EN::Inflect::def_noun '(.*)staff' => '$1staves'; # policy
717# Lingua::EN::Inflect::def_noun '(.*)boots' => '$1boots'; # hack
718#
719# for my $a (@ARC) {
720# my $name = $a->{name} || $a->{_name};
721#
722# next unless $a->{name_pl};
723# next if $a->{invisible};
724# next if $a->{is_floor};
725# next if $a->{no_pick};
726#
727# my $test = Lingua::EN::Inflect::PL_N_eq $name, Lingua::EN::Inflect::PL $name;
728# my $pl = $test =~ /^(?:eq|p:.)$/
729# ? $name
730# : Lingua::EN::Inflect::PL $name;
731#
732# if ($pl ne $a->{name_pl}) {
733# warn "$a->{_name}: plural differs, $pl vs $a->{name_pl}\n";
734# }
735# }
372 } 736 }
373 737
374 sub inst_arch($) { 738 sub inst_arch($) {
375 my (undef, $path) = @_; 739 my (undef, $path) = @_;
376 740
741 $PATH = $path;
742
743 print "\n",
377 print "Installing '$path' to '$DATADIR'\n", 744 "Installing '$path' to '$DATADIR'\n",
745 "\n",
378 "This can take a long time if you run this\n", 746 "This can take a long time if you run this\n",
379 "for the first time or do not use --cache.\n", 747 "for the first time or do not use --cache.\n",
380 "\n", 748 "\n",
381 "Unless you run verbosely, all following warning\n", 749 "Unless you run verbosely, all following warning\n",
382 "or error messages indicate serious problems.\n", 750 "or error messages indicate serious problems.\n",
385 if (!-d "$path/treasures") { 753 if (!-d "$path/treasures") {
386 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 754 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
387 exit 1 unless $FORCE; 755 exit 1 unless $FORCE;
388 } 756 }
389 757
758 print "start file scan, arc, any processing...\n" if $VERBOSE;
759
760 my @a_arc = map +(async \&process_arc), 1..2;
761 my @a_any = map +(async \&process_any), 1..4;
762
390 find_files $path; 763 find_files $path;
391 IO::AIO::flush;
392 764
393 $_->join for ( 765 $c_arc->shutdown;
766 $c_any->shutdown;
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 print "end any processing...\n" if $VERBOSE;
776 $_->join for @a_any;
777
778 print "end png processing...\n" if $VERBOSE;
779 $_->join for @a_png;
780
781 print "scanning done, processing results...\n" if $VERBOSE;
400 { 782 {
401 # remove path prefix from editor_folder 783 # remove path prefix from editor_folder
784 $_->{editor_folder} =~ /^\x00/
402 substr $_->{editor_folder}, 0, 1 + length $path, "" 785 and substr $_->{editor_folder}, 0, 2 + length $path, ""
403 for values %ARC; 786 for values %ARC;
404 787
788 print "resolving inheritance tree...\n" if $VERBOSE;
405 # resolve inherit 789 # resolve inherit
406 while () { 790 while () {
407 my $progress; 791 my $progress;
408 my $loop; 792 my $loop;
409 793
410 for my $o (values %ARC) { 794 for my $o (values %ARC) {
411 if (my $other = $o->{inherit}) { 795 for my $other (split /,/, $o->{inherit}) {
412 if (my $s = $ARC{$other}) { 796 if (my $s = $ARC{$other}) {
413 if ($s->{inherit}) { 797 if ($s->{inherit}) {
414 $loop = $s; 798 $loop = $s;
415 } else { 799 } else {
416 delete $o->{inherit}; 800 delete $o->{inherit};
801 my %s = %$s;
802 delete @s{qw(_name more name name_pl)};
417 %$o = ( %$s, %$o ); 803 %$o = ( %s, %$o );
418 ++$progress; 804 ++$progress;
419 } 805 }
420 } else { 806 } else {
421 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n"; 807 warn "WARNING: archetype '$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
422 delete $ARC{$o->{_name}}; 808 delete $ARC{$o->{_name}};
423 } 809 }
424 } 810 }
425 } 811 }
426 812
430 816
431 last; 817 last;
432 } 818 }
433 } 819 }
434 820
821 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
822 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC;
823
824 # fix up archetypes without names, where the archanme doesn't work at all
825 for (@ARC) {
826 if (!exists $_->{name} and $_->{_name} =~ /_/) {
827 for ($_->{name} = $_->{_name}) {
828 s/(?:_\d+)+$//;
829 s/_[nesw]+$//;
830 y/_/ /;
831 }
832 }
833 }
834
835 #print "generating plurals...\n" if $VERBOSE;
836 #generate_plurals;
837
838 printf "writing %d archetypes...\n", scalar @ARC if $VERBOSE;
435 open my $fh, ">:utf8", "$DATADIR/archetypes~" 839 open my $fh, ">:utf8", "$DATADIR/archetypes~"
436 or die "$DATADIR/archetypes~: $!"; 840 or die "$DATADIR/archetypes~: $!";
437 print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } values %ARC]; 841 print $fh Deliantra::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
438 } 842 }
439 843
440 { 844 {
845 printf "writing treasures (%d octets)...\n", length $TRS if $VERBOSE;
441 open my $fh, ">:utf8", "$DATADIR/treasures~" 846 open my $fh, ">:utf8", "$DATADIR/treasures~"
442 or die "$DATADIR/treasures~: $!"; 847 or die "$DATADIR/treasures~: $!";
443 print $fh $TRS; 848 print $fh $TRS;
444 } 849 }
445 850
446 { 851 {
852 print "processing facedata...\n" if $VERBOSE;
447 while (my ($k, $v) = each %FACEINFO) { 853 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"; 854 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"; 855 length $v->{data64} or warn "WARNING: face '$k' has no png64. this will not work very well.\n";
450 856
857 make_hash $k, $v->{data32}, $v->{hash32};
858 make_hash $k, $v->{data64}, $v->{hash64};
859
451 length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n"; 860 #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"; 861 #length $v->{data64} <= 10000 or warn "WARNING: face '$k' has face64 larger than 10000 bytes.\n";
453 862
454 $v->{chksum32} = Digest::MD5::md5 $v->{data32}; 863 $v->{glyph} // warn "WARNING: face '$k' has glyph.";
455 $v->{chksum64} = Digest::MD5::md5 $v->{data64}; 864 $v->{visibility} // warn "WARNING: face '$k' has no visibility info, missing faceinfo entry?\n";
865 $v->{magicmap} // warn "WARNING: face '$k' has foreground colour.";
866
867 delete @$v{qw(arc stem)}; # not used by the server
868 }
869
870 print "processing resources...\n" if $VERBOSE;
871 my $enc = JSON::XS->new->utf8->canonical->relaxed;
872 while (my ($k, $v) = each %RESOURCE) {
873
874 if ($v->{meta} && $v->{meta}{datadir}) {
875 delete $RESOURCE{$k};
876
877 $k =~ s/^res\/// or die "$k: datadir files must be in res/";
878
879 printf "writing $k (%d octets)...\n", length $v->{data} if $VERBOSE;
880 open my $fh, ">:raw", "$DATADIR/$k~"
881 or die "$DATADIR/$k~: $!";
882 syswrite $fh, $v->{data};
883 push @COMMIT, $k;
884
885 } else {
886 if ($v->{type} & 1) {
887 # prepend meta info
888
889 my $meta = $enc->encode ({
890 name => $k,
891 %{ $v->{meta} || {} },
892 });
893
894 $v->{data} = pack "(w/a*)*", $meta, $v->{data};
895 }
896
897 make_hash $k, $v->{data}, $v->{hash}, 6; # 6 for the benefit of existing clients
456 } 898 }
899 }
900
901 printf "writing facedata (%d faces, %d anims, %d resources)...\n",
902 scalar keys %FACEINFO,
903 scalar keys %ANIMINFO,
904 scalar keys %RESOURCE
905 if $VERBOSE;
457 906
458 open my $fh, ">:perlio", "$DATADIR/facedata~" 907 open my $fh, ">:perlio", "$DATADIR/facedata~"
459 or die "$DATADIR/facedata~: $!"; 908 or die "$DATADIR/facedata~: $!";
460 909
461 print $fh freeze { 910 print $fh nfreeze {
462 version => 2, 911 version => 2,
463 faceinfo => \%FACEINFO, 912 faceinfo => \%FACEINFO,
464 animinfo => \%ANIMINFO, 913 animinfo => \%ANIMINFO,
914 resource => \%RESOURCE,
465 }; 915 };
466 }
467 916
917 }
918
919 print "committing files...\n" if $VERBOSE;
920
468 for (qw(archetypes facedata treasures)) { 921 for (qw(archetypes facedata treasures), @COMMIT) {
469 chmod 0644, "$DATADIR/$_~"; 922 chmod 0644, "$DATADIR/$_~";
470 rename "$DATADIR/$_~", "$DATADIR/$_" 923 rename "$DATADIR/$_~", "$DATADIR/$_"
471 or die "$DATADIR/$_: $!"; 924 or die "$DATADIR/$_: $!";
472 } 925 }
473 926

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines