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

Diff Legend

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