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.56 by root, Sun Aug 19 15:47:56 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 <$base>, 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->{move_block} eq "all"
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
… …
308 frames => \@frames, 427 frames => \@frames,
309 }; 428 };
310 } 429 }
311 430
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/;
314 433
315 my $info = $FACEINFO{$face} ||= {}; 434 my $info = $FACEINFO{$face} ||= { };
435 $info->{arc} = $o;
436
437 next if $face =~ /^blank.x11$|^empty.x11$/;
316 438
317 $info->{visibility} = $visibility if defined $visibility; 439 $info->{visibility} = $visibility if defined $visibility;
318 $info->{magicmap} = $magicmap if defined $magicmap; 440 $info->{magicmap} = $magicmap if defined $magicmap;
319 } 441 }
320 442
321 if (my $smooth = delete $o->{smoothface}) { 443 if (my $smooth = delete $o->{smoothface}) {
322 my %kv =split /\s+/, $smooth; 444 my %kv = split /\s+/, $smooth;
323 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support 445 my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
324 while (my ($face, $smooth) = each %kv) { 446 while (my ($face, $smooth) = each %kv) {
447 $FACEINFO{$smooth}{arc} = $o;
448
325 $FACEINFO{$face}{smooth} = $smooth; 449 $FACEINFO{$face}{smooth} = $smooth;
326 $FACEINFO{$face}{smoothlevel} = $level; 450 $FACEINFO{$face}{smoothlevel} = $level;
327 } 451 }
328 } 452 }
329 } 453 }
330 } 454 }
331 } 455 }
332 } 456 }
333 457
334 sub process_trs { 458 sub process_trs {
335 while (@trs) { 459 while (my $job = $c_trs->get) {
336 my ($dir, $file) = @{pop @trs}; 460 my ($dir, $file) = @$job;
337 my $path = "$dir/$file"; 461 my $path = "$dir/$file";
338 462
339 my $trs; 463 my $trs;
340 if (0 > aio_load $path, $trs) { 464 if (0 > aio_load $path, $trs) {
341 warn "$path: $!, skipping.\n"; 465 warn "$path: $!, skipping.\n";
… …
344 468
345 $TRS .= $trs; 469 $TRS .= $trs;
346 } 470 }
347 } 471 }
348 472
473 my %FILECACHE;
474
475 sub load_cached($;$) {
476 unless (exists $FILECACHE{$_[0]}) {
477 my $data;
478 if (0 < aio_load $_[0], $data) {
479 if ($_[1]) {
480 $data = eval { $_[1]->($data) };
481 warn "$_[0]: $@" if $@;
482 }
483 }
484
485 $FILECACHE{$_[0]} = $data;
486 }
487
488 $FILECACHE{$_[0]}
489 }
490
491 sub process_res {
492 while (my $job = $c_res->get) {
493 my ($dir, $file, $type) = @$job;
494
495 my $data;
496 aio_load "$dir/$file", $data;
497
498 my $meta = load_cached "$dir/meta", sub { JSON::XS::from_json shift };
499
500 next if $meta && !exists $meta->{$file};
501
502 $meta = {
503 %{ $meta->{"" } || {} },
504 %{ $meta->{$file} || {} },
505 };
506
507 if ($meta->{license} =~ s/^#//) {
508 $meta->{license} = ({
509 "pd" => "Public Domain",
510 "gpl" => "GNU General Public License, version 3.0 or any later",
511 "cc/by/2.0" => "Licensed under Creative Commons Attribution 2.0 http://creativecommons.org/licenses/by/2.0/",
512 "cc/by/2.5" => "Licensed under Creative Commons Attribution 2.5 http://creativecommons.org/licenses/by/2.5/",
513 "cc/by/3.0" => "Licensed under Creative Commons Attribution 3.0 http://creativecommons.org/licenses/by/3.0/",
514 })->{$meta->{license}}
515 || warn "$dir/$file: license tag '$meta->{license}' not found.";
516 }
517
518 $file =~ s/\.res$//;
519 $file =~ s/\.(ogg|wav|jpg|png)$//;
520
521 substr $dir, 0, 1 + length $PATH, "";
522
523 $RESOURCE{"$dir/$file"} = {
524 type => (delete $meta->{type}) || $type,
525 data => $data,
526 chksum => (Digest::MD5::md5 $data),
527 %$meta ? (meta => $meta) : (),
528 };
529 }
530 }
531
349 sub find_files; 532 sub find_files;
350 sub find_files { 533 sub find_files {
351 my ($path) = @_; 534 my ($path) = @_;
352 535
353 IO::AIO::aioreq_pri 4; 536 IO::AIO::aioreq_pri 4;
… …
355 my ($dirs, $nondirs) = @_; 538 my ($dirs, $nondirs) = @_;
356 539
357 find_files "$path/$_" 540 find_files "$path/$_"
358 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs; 541 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs;
359 542
543 my $dir = $path;
544 substr $dir, 0, 1 + length $PATH, "";
545
360 for my $file (@$nondirs) { 546 for my $file (@$nondirs) {
547 if ($dir =~ /^music(?:\/|$)/) {
548 $c_res->put ([$path, $file, 3]) # FT_MUSIC
549 if $file =~ /\.(ogg)$/;
550
551 } elsif ($dir =~ /^sound(?:\/|$)/) {
552 $c_res->put ([$path, $file, 5]) # FT_SOUND
553 if $file =~ /\.(wav|ogg)$/;
554
555 } elsif ($dir =~ /^res(?:\/|$)/) {
556 $c_res->put ([$path, $file, 0]) # FT_FACE
557 if $file =~ /\.(jpg|png)$/;
558 $c_res->put ([$path, $file, 7]) # FT_RSRC
559 if $file =~ /\.(res)$/;
560
361 if ($file =~ /\.png$/) { 561 } elsif ($file =~ /\.png$/) {
362 push @png, ["$path/$file", 0]; 562 push @c_png, ["$path/$file", 0];
563
363 } elsif ($file =~ /\.trs$/) { 564 } elsif ($file =~ /\.trs$/) {
364 push @trs, [$path, $file]; 565 $c_trs->put ([$path, $file]);
566
365 } elsif ($file =~ /\.arc$/) { 567 } elsif ($file =~ /\.arc$/) {
366 push @arc, [$path, $file]; 568 $c_arc->put ([$path, $file]);
569
367 } else { 570 } else {
368 warn "ignoring $path/$file\n" if $VERBOSE >= 2; 571 warn "ignoring $path/$file\n" if $VERBOSE >= 3;
369 } 572 }
370 } 573 }
371 }; 574 };
372 } 575 }
373 576
374 sub inst_arch($) { 577 sub inst_arch($) {
375 my (undef, $path) = @_; 578 my (undef, $path) = @_;
376 579
580 $PATH = $path;
581
582 print "\n",
377 print "Installing '$path' to '$DATADIR'\n", 583 "Installing '$path' to '$DATADIR'\n",
584 "\n",
378 "This can take a long time if you run this\n", 585 "This can take a long time if you run this\n",
379 "for the first time or do not use --cache.\n", 586 "for the first time or do not use --cache.\n",
380 "\n", 587 "\n",
381 "Unless you run verbosely, all following warning\n", 588 "Unless you run verbosely, all following warning\n",
382 "or error messages indicate serious problems.\n", 589 "or error messages indicate serious problems.\n",
… …
385 if (!-d "$path/treasures") { 592 if (!-d "$path/treasures") {
386 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n"; 593 warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
387 exit 1 unless $FORCE; 594 exit 1 unless $FORCE;
388 } 595 }
389 596
597 print "scanning files...\n" if $VERBOSE;
598
390 find_files $path; 599 find_files $path;
600
601 my @a_arc = map +(async \&process_arc), 1..2;
602 my @a_res = map +(async \&process_res), 1..2;
603 my @a_trs = map +(async \&process_trs), 1..2;
604
391 IO::AIO::flush; 605 IO::AIO::flush;
392 606
393 $_->join for ( 607 $c_res->put (undef) for @a_res;
608 $c_arc->put (undef) for @a_arc;
609 $c_trs->put (undef) for @a_trs;
610
611 print "start file scan, arc, res processing...\n" if $VERBOSE;
612
613 $_->join for @a_arc; # need to parse all archetypes before png processing
614
615 print "end arc, start png processing...\n" if $VERBOSE;
616
394 # four png crunchers work fine for my 2x smp machine 617 # four png crunchers work fine for my 2x smp machine
395 (async \&process_png), (async \&process_png), (async \&process_png), (async \&process_png), 618 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 619
620 $_->join for (@a_trs, @a_res, @a_png);
621
622 print "scanning done, processing results...\n" if $VERBOSE;
400 { 623 {
401 # remove path prefix from editor_folder 624 # remove path prefix from editor_folder
402 substr $_->{editor_folder}, 0, 1 + length $path, "" 625 substr $_->{editor_folder}, 0, 1 + length $path, ""
403 for values %ARC; 626 for values %ARC;
404 627
628 print "resolving inheritance tree...\n" if $VERBOSE;
405 # resolve inherit 629 # resolve inherit
406 while () { 630 while () {
407 my $progress; 631 my $progress;
408 my $loop; 632 my $loop;
409 633
… …
412 if (my $s = $ARC{$other}) { 636 if (my $s = $ARC{$other}) {
413 if ($s->{inherit}) { 637 if ($s->{inherit}) {
414 $loop = $s; 638 $loop = $s;
415 } else { 639 } else {
416 delete $o->{inherit}; 640 delete $o->{inherit};
641 my %s = %$s;
642 delete @s{qw(_name more name name_pl)};
417 %$o = ( %$s, %$o ); 643 %$o = ( %s, %$o );
418 ++$progress; 644 ++$progress;
419 } 645 }
420 } else { 646 } else {
421 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n"; 647 warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
422 delete $ARC{$o->{_name}}; 648 delete $ARC{$o->{_name}};
… …
430 656
431 last; 657 last;
432 } 658 }
433 } 659 }
434 660
661 # remove base classes (by naming scheme, should use something like "baseclass xxx" to inherit
662 @ARC = grep $_->{_name} !~ /^(?:type|class)_/, @ARC;
663
664 print "writing archetypes...\n" if $VERBOSE;
435 open my $fh, ">:utf8", "$DATADIR/archetypes~" 665 open my $fh, ">:utf8", "$DATADIR/archetypes~"
436 or die "$DATADIR/archetypes~: $!"; 666 or die "$DATADIR/archetypes~: $!";
437 print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } values %ARC]; 667 print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
438 } 668 }
439 669
440 { 670 {
671 print "writing treasures...\n" if $VERBOSE;
441 open my $fh, ">:utf8", "$DATADIR/treasures~" 672 open my $fh, ">:utf8", "$DATADIR/treasures~"
442 or die "$DATADIR/treasures~: $!"; 673 or die "$DATADIR/treasures~: $!";
443 print $fh $TRS; 674 print $fh $TRS;
444 } 675 }
445 676
446 { 677 {
678 print "processing facedata...\n" if $VERBOSE;
447 while (my ($k, $v) = each %FACEINFO) { 679 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"; 680 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"; 681 length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
450 682
451 length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n"; 683 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"; 684 #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
453 685
454 $v->{chksum32} = Digest::MD5::md5 $v->{data32}; 686 $v->{chksum32} = Digest::MD5::md5 $v->{data32};
455 $v->{chksum64} = Digest::MD5::md5 $v->{data64}; 687 $v->{chksum64} = Digest::MD5::md5 $v->{data64};
688
689 if (my $magicmap = $v->{magicmap}) {
690 $magicmap =~ y/A-Z_\-/a-z/d;
691 $v->{magicmap} = $COLOR{$magicmap};
456 } 692 }
457 693
694 delete $v->{arc};
695 }
696
697 print "writing facedata...\n" if $VERBOSE;
458 open my $fh, ">:perlio", "$DATADIR/facedata~" 698 open my $fh, ">:perlio", "$DATADIR/facedata~"
459 or die "$DATADIR/facedata~: $!"; 699 or die "$DATADIR/facedata~: $!";
460 700
461 print $fh freeze { 701 print $fh freeze {
462 version => 2, 702 version => 2,
463 faceinfo => \%FACEINFO, 703 faceinfo => \%FACEINFO,
464 animinfo => \%ANIMINFO, 704 animinfo => \%ANIMINFO,
705 resource => \%RESOURCE,
465 }; 706 };
466 } 707 }
708
709 print "committing files...\n" if $VERBOSE;
467 710
468 for (qw(archetypes facedata treasures)) { 711 for (qw(archetypes facedata treasures)) {
469 chmod 0644, "$DATADIR/$_~"; 712 chmod 0644, "$DATADIR/$_~";
470 rename "$DATADIR/$_~", "$DATADIR/$_" 713 rename "$DATADIR/$_~", "$DATADIR/$_"
471 or die "$DATADIR/$_: $!"; 714 or die "$DATADIR/$_: $!";

Diff Legend

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