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.57 by root, Mon Aug 20 22:09:04 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 Carp;
27use Coro::Channel;
25use Coro::Storable; $Storable::canonical = 1; 28use Coro::Storable; $Storable::canonical = 1;
29
30$SIG{QUIT} = sub { Carp::cluck "QUIT" };
26 31
27sub usage { 32sub usage {
28 warn <<EOF; 33 warn <<EOF;
29Usage: cfutil [-v] [-q] [--force] [--cache] 34Usage: cfutil [-v] [-q] [--force] [--cache]
30 [--install-arch path] 35 [--install-arch path]
… …
42my $CACHE = 0; 47my $CACHE = 0;
43my $FORCE; 48my $FORCE;
44my $TMPDIR = "/tmp/cfutil$$~"; 49my $TMPDIR = "/tmp/cfutil$$~";
45my $TMPFILE = "aaaa0"; 50my $TMPFILE = "aaaa0";
46 51
52our %COLOR = (
53 black => 0,
54 white => 1,
55 navy => 2,
56 red => 3,
57 orange => 4,
58 blue => 5,
59 darkorange => 6,
60 green => 7,
61 lightgreen => 8,
62 grey => 9,
63 brown => 10,
64 gold => 11,
65 tan => 12,
66);
67
47END { system "rm", "-rf", $TMPDIR } 68END { system "rm", "-rf", $TMPDIR }
48 69
49Event->signal (signal => "INT", cb => sub { exit 1 }); 70Event->signal (signal => "INT", cb => sub { exit 1 });
50Event->signal (signal => "TERM", cb => sub { exit 1 }); 71Event->signal (signal => "TERM", cb => sub { exit 1 });
51 72
… …
68} 89}
69 90
70sub inst_maps($) { 91sub inst_maps($) {
71 my (undef, $path) = @_; 92 my (undef, $path) = @_;
72 93
73 print "installing '$path' to '$DATADIR/maps'\n"; 94 print "\nInstalling '$path' to '$DATADIR/maps'\n\n";
74 95
75 if (!-f "$path/regions") { 96 if (!-f "$path/regions") {
76 warn "'$path' does not look like a maps directory ('regions' file is missing).\n"; 97 warn "'$path' does not look like a maps directory ('regions' file is missing).\n";
77 exit 1 unless $FORCE; 98 exit 1 unless $FORCE;
78 } 99 }
79 100
80 system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded" 101 system $RSYNC, "-a", "--chmod=u=rwX,go=rX", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded"
81 and die "map installation failed.\n"; 102 and die "map installation failed.\n";
82 103
83 print "maps installed successfully.\n"; 104 print "maps installed successfully.\n";
84} 105}
85 106
86{ 107{
87 our %ANIMINFO; 108 our %ANIMINFO;
88 our %FACEINFO; 109 our %FACEINFO;
110 our %RESOURCE;
111 our @ARC;
89 our %ARC; 112 our %ARC;
90 our $TRS; 113 our $TRS;
91 our $NFILE; 114 our $NFILE;
115 our $PATH;
92 116
93 our $QUANTIZE = "+dither -colorspace RGB -colors 256"; 117 our $QUANTIZE = "+dither -colorspace RGB -colors 256";
94 118
95 our (@png, @trs, @arc); # files we are interested in 119 our $c_arc = new Coro::Channel;
120 our $c_trs = new Coro::Channel;
121 our $c_res = new Coro::Channel;
122
123 our @c_png;
96 124
97 sub commit_png($$$) { 125 sub commit_png($$$) {
98 my ($name, $data, $T) = @_; 126 my ($name, $data, $T) = @_;
99 127
100 $FACEINFO{$name}{"data$T"} = $data; 128 $FACEINFO{$name}{"data$T"} = $data;
101 } 129 }
102 130
103 sub process_png { 131 sub process_png {
104 while (@png) { 132 while (@c_png) {
105 my ($path, $delete) = @{pop @png}; 133 my ($path, $delete) = @{pop @c_png};
106 134
107 my $png; 135 my $png;
108 aio_lstat $path; 136 aio_lstat $path;
109 my ($size, $mtime) = (stat _)[7,9]; 137 my ($size, $mtime) = (stat _)[7,9];
110 138
… …
141 if ($w % $T || $h % $T) { 169 if ($w % $T || $h % $T) {
142 warn "$path: weird png size ($w $h), skipping.\n"; 170 warn "$path: weird png size ($w $h), skipping.\n";
143 next; 171 next;
144 } 172 }
145 173
174 (my $base = $stem) =~ s/^.*\///;
175
176 my $fi = $FACEINFO{$base};
177 unless ($fi) {
178 warn "$path: <$base> not referenced by any archetype, skipping.\n";
179 next;
180 }
181
182 my $arc = $FACEINFO{$base}{arc}
183 or die "FATAL: internal error <$base>, cannot continue";
184
146 unless ($path =~ /~$/) { 185 unless ($path =~ /~$/) {
147 # possibly enlarge 186 # possibly enlarge
148 if (0 > aio_stat "$stem.64x64.png") { 187 if (0 > aio_stat "$stem.64x64.png") {
149 my $other = "$stem.64x64.png~"; 188 my $other = "$stem.64x64.png~";
150 189
151 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 190 if (0 > aio_lstat $other or (-M _) > (-M $path)) {
152 my $wrap = 0; # for the time being
153 fork_sub { 191 fork_sub {
192 my $CROP;
193 my $SRC = "png:\Q$path\E";
194
195 my $is_floor = $arc->{is_floor};
196 my $is_wall = 0;
197
198 my ($wall_pfx, $wall_dir, $wall_sfx);
199
200 if (
201 !$is_floor
202 && !$arc->{alive}
203 && $arc->{move_block} eq "all"
204 && $path =~ /^(.*_)([0-9A-F])(\.x11.*\.png)$/
205 ) {
206 ($wall_pfx, $wall_dir, $wall_sfx) = ($1, hex $2, $3);
207
208 unless (grep { !-e sprintf "%s%X%s", $wall_pfx, $_, $wall_sfx } 0..15) {
209 $is_wall = 1;
210 }
211 }
212
213 if ($is_wall || $is_floor) {
214 # add a 4px border and add other images around it
215 $CROP = "-shave 8x8 +repage";
216
217 $w += 8;
218 $h += 8;
219
220 $SRC = "-size ${w}x${h} xc:transparent";
221 $SRC .= " png:\Q$path\E -geometry +4+4 -composite";
222
223 # 8 surrounding images
224 for (
225 # x y b r0 r1
226 [-1, -1, 0, 6],
227 [ 0, -1, 1, 10, 14],
228 [+1, -1, 0, 12],
229
230 [-1, 0, 8, 5, 7],
231 #
232 [+1, 0, 2, 5, 13],
233
234 [-1, +1, 0, 3],
235 [ 0, +1, 4, 10, 11],
236 [+1, +1, 0, 9],
237 ) {
238 my ($x, $y, $d, $r0, $r1) = @$_;
239
240 my $tile = $is_floor ? $path
241 : $is_wall ? sprintf "%s%X%s", $wall_pfx, ($wall_dir & $d) ? $r1 : $r0, $wall_sfx
242 : die;
243
244 $SRC .= sprintf " png:%s -geometry %+d%+d -composite",
245 "\Q$tile",
246 $x * ($w - 8) + 4,
247 $y * ($h - 8) + 4;
248 }
249 }
250
154 system "convert png:\Q$path\E -depth 8 rgba:-" 251 system "convert -depth 8 $SRC rgba:-"
155 . "| $exec_prefix/bin/cfhq2xa $w $h $wrap" 252 . "| $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~" 253 . "| 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 $? ($!)"; 254 and die "convert/cfhq2xa pipeline error: status $? ($!)";
158 system $OPTIPNG, "-o5", "-i0", "-q", "$other~"; 255 system $OPTIPNG, "-i0", "-q", "$other~";
159 die "$other~ has zero size, aborting." unless -s "$other~"; 256 die "$other~ has zero size, aborting." unless -s "$other~";
160 rename "$other~", $other; 257 rename "$other~", $other;
161 }; 258 };
162 } 259 }
163 260
164 push @png, [$other, !$CACHE]; 261 push @c_png, [$other, !$CACHE];
165 } 262 }
166 263
167 # possibly scale down 264 # possibly scale down
168 if (0 > aio_stat "$stem.32x32.png") { 265 if (0 > aio_stat "$stem.32x32.png") {
169 my $other = "$stem.32x32.png~"; 266 my $other = "$stem.32x32.png~";
170 267
171 if (0 > aio_lstat $other or (-M _) > (-M $path)) { 268 if (0 > aio_lstat $other or (-M _) > (-M $path)) {
172 fork_sub { 269 fork_sub {
173 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~"; 270 system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
174 system $OPTIPNG, "-o5", "-i0", "-q", "$other~"; 271 system $OPTIPNG, "-i0", "-q", "$other~";
272
273 # reduce smoothfaces >10000 bytes
274 if ($stem =~ /_S\./ && (-s "$other~") > 10000) {
275 my $ncolor = 256;
276 while () {
277 system "<\Q$other~\E $PNGNQ -s1 -n$ncolor >\Q$other~~\E";
278 system $OPTIPNG, "-i0", "-q", "$other~~";
279 last if 10000 > -s "$other~~";
280 $ncolor = int $ncolor * 0.9;
281 $ncolor > 8 or die "cannot reduce filesize to < 10000 bytes";
282 }
283
284 printf "reduced %s from %d to %d bytes using %d colours.\n",
285 $other, -s "$other~", -s "$other~~", $ncolor
286 if $VERBOSE >= 2;
287 rename "$other~~", "$other~";
288 }
289
175 die "$other~ has zero size, aborting." unless -s "$other~"; 290 die "$other~ has zero size, aborting." unless -s "$other~";
176 rename "$other~", $other; 291 rename "$other~", $other;
177 }; 292 };
178 } 293 }
179 294
180 #warn "scaled down $path to $other\n";#d# 295 #warn "scaled down $path to $other\n";#d#
181 push @png, [$other, !$CACHE]; 296 push @c_png, [$other, !$CACHE];
182 } 297 }
183 } 298 }
184 299
185 (my $face = $stem) =~ s/^.*\///; 300 (my $face = $stem) =~ s/^.*\///;
186 301
… …
247 aio_unlink $path if $delete; 362 aio_unlink $path if $delete;
248 } 363 }
249 } 364 }
250 365
251 sub process_arc { 366 sub process_arc {
252 while (@arc) { 367 while (my $job = $c_arc->get) {
253 my ($dir, $file) = @{pop @arc}; 368 my ($dir, $file) = @$job;
254 369
255 my $arc; 370 my $arc;
256 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/ 371 aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
257 372
258 my $arc = read_arch "$dir/$file"; 373 my $arc = read_arch "$dir/$file";
259 for my $o (values %$arc) { 374 for my $o (values %$arc) {
375 push @ARC, $o;
376 for (my $m = $o; $m; $m = $m->{more}) {
260 $ARC{$o->{_name}} = $o; 377 $ARC{$m->{_name}} = $m;
378 }
261 379
262 $o->{editor_folder} = $dir; 380 $o->{editor_folder} = $dir;
263 381
264 my $visibility = delete $o->{visibility}; 382 my $visibility = delete $o->{visibility};
265 my $magicmap = delete $o->{magicmap}; 383 my $magicmap = delete $o->{magicmap};
… …
278 396
279 my $ext = $x|$y ? "+$x+$y" : ""; 397 my $ext = $x|$y ? "+$x+$y" : "";
280 398
281 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face}; 399 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face};
282 400
283 my $visibility = delete $o->{visibility} if exists $o->{visibility}; 401 $visibility = delete $o->{visibility} if exists $o->{visibility};
284 my $magicmap = delete $o->{magicmap} if exists $o->{magicmap}; 402 $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
285 403
286 my $anim = delete $o->{anim}; 404 my $anim = delete $o->{anim};
287 405
288 if ($anim) { 406 if ($anim) {
289 # possibly add $ext to the animation name to avoid 407 # possibly add $ext to the animation name to avoid
… …
308 frames => \@frames, 426 frames => \@frames,
309 }; 427 };
310 } 428 }
311 429
312 for my $face ($o->{face} || (), @{$anim || []}) { 430 for my $face ($o->{face} || (), @{$anim || []}) {
313 next if $face =~ /^facings\s|^blank.x11$|^empty.x11$/; 431 next if $face =~ /^facings\s/;
314 432
315 my $info = $FACEINFO{$face} ||= {}; 433 my $info = $FACEINFO{$face} ||= { };
434 $info->{arc} = $o;
435
436 next if $face =~ /^blank.x11$|^empty.x11$/;
316 437
317 $info->{visibility} = $visibility if defined $visibility; 438 $info->{visibility} = $visibility if defined $visibility;
318 $info->{magicmap} = $magicmap if defined $magicmap; 439 $info->{magicmap} = $magicmap if defined $magicmap;
319 } 440 }
320 441
321 if (my $smooth = delete $o->{smoothface}) { 442 if (my $smooth = delete $o->{smoothface}) {
322 my %kv =split /\s+/, $smooth; 443 my %kv = split /\s+/, $smooth;
323 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 444 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
324 while (my ($face, $smooth) = each %kv) { 445 while (my ($face, $smooth) = each %kv) {
446 $FACEINFO{$smooth}{arc} = $o;
447
325 $FACEINFO{$face}{smooth} = $smooth; 448 $FACEINFO{$face}{smooth} = $smooth;
326 $FACEINFO{$face}{smoothlevel} = $level; 449 $FACEINFO{$face}{smoothlevel} = $level;
327 } 450 }
328 } 451 }
329 } 452 }
330 } 453 }
331 } 454 }
332 } 455 }
333 456
334 sub process_trs { 457 sub process_trs {
335 while (@trs) { 458 while (my $job = $c_trs->get) {
336 my ($dir, $file) = @{pop @trs}; 459 my ($dir, $file) = @$job;
337 my $path = "$dir/$file"; 460 my $path = "$dir/$file";
338 461
339 my $trs; 462 my $trs;
340 if (0 > aio_load $path, $trs) { 463 if (0 > aio_load $path, $trs) {
341 warn "$path: $!, skipping.\n"; 464 warn "$path: $!, skipping.\n";
… …
344 467
345 $TRS .= $trs; 468 $TRS .= $trs;
346 } 469 }
347 } 470 }
348 471
472 my %FILECACHE;
473
474 sub load_cached($;$) {
475 unless (exists $FILECACHE{$_[0]}) {
476 my $data;
477 if (0 < aio_load $_[0], $data) {
478 if ($_[1]) {
479 $data = eval { $_[1]->($data) };
480 warn "$_[0]: $@" if $@;
481 }
482 }
483
484 $FILECACHE{$_[0]} = $data;
485 }
486
487 $FILECACHE{$_[0]}
488 }
489
490 sub process_res {
491 while (my $job = $c_res->get) {
492 my ($dir, $file, $type) = @$job;
493
494 my $data;
495 aio_load "$dir/$file", $data;
496
497 my $meta = load_cached "$dir/meta", sub { JSON::XS::from_json shift };
498
499 next if $meta && !exists $meta->{$file};
500
501 $meta = {
502 %{ $meta->{"" } || {} },
503 %{ $meta->{$file} || {} },
504 };
505
506 if ($meta->{license} =~ s/^#//) {
507 $meta->{license} = ({
508 "pd" => "Public Domain",
509 "gpl" => "GNU General Public License, version 3.0 or any later",
510 "cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
511 "cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
512 "cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
513 })->{$meta->{license}}
514 || warn "$dir/$file: license tag '$meta->{license}' not found.";
515 }
516
517 $file =~ s/\.res$//;
518 $file =~ s/\.(ogg|wav|jpg|png)$//;
519
520 substr $dir, 0, 1 + length $PATH, "";
521
522 $RESOURCE{"$dir/$file"} = {
523 type => (delete $meta->{type}) || $type,
524 data => $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 if (my $magicmap = $v->{magicmap}) {
455 $v->{chksum64} = Digest::MD5::md5 $v->{data64}; 685 $magicmap =~ y/A-Z_\-/a-z/d;
686 $v->{magicmap} = $COLOR{$magicmap};
456 } 687 }
457 688
689 delete $v->{arc};
690 }
691
692 print "writing facedata...\n" if $VERBOSE;
458 open my $fh, ">:perlio", "$DATADIR/facedata~" 693 open my $fh, ">:perlio", "$DATADIR/facedata~"
459 or die "$DATADIR/facedata~: $!"; 694 or die "$DATADIR/facedata~: $!";
460 695
461 print $fh freeze { 696 print $fh freeze {
462 version => 2, 697 version => 2,
463 faceinfo => \%FACEINFO, 698 faceinfo => \%FACEINFO,
464 animinfo => \%ANIMINFO, 699 animinfo => \%ANIMINFO,
700 resource => \%RESOURCE,
465 }; 701 };
466 } 702 }
703
704 print "committing files...\n" if $VERBOSE;
467 705
468 for (qw(archetypes facedata treasures)) { 706 for (qw(archetypes facedata treasures)) {
469 chmod 0644, "$DATADIR/$_~"; 707 chmod 0644, "$DATADIR/$_~";
470 rename "$DATADIR/$_~", "$DATADIR/$_" 708 rename "$DATADIR/$_~", "$DATADIR/$_"
471 or die "$DATADIR/$_: $!"; 709 or die "$DATADIR/$_: $!";

Diff Legend

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