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.54 by root, Sun Aug 19 10:28:52 2007 UTC

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

Diff Legend

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