ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/utils/cfutil.in
Revision: 1.16
Committed: Wed Mar 14 15:47:21 2007 UTC (17 years, 2 months ago) by root
Branch: MAIN
Changes since 1.15: +1 -1 lines
Log Message:
thinko

File Contents

# User Rev Content
1 root 1.1 #!@PERL@
2    
3 root 1.2 use strict;
4    
5     my $prefix = "@prefix@";
6     my $exec_prefix = "@exec_prefix@";
7     my $datarootdir = "@datarootdir@";
8     my $DATADIR = "@datadir@/@PACKAGE@";
9    
10     my $CONVERT = "@CONVERT@";
11     my $IDENTIFY = "@IDENTIFY@";
12 root 1.3 my $OPTIPNG = "@OPTIPNG@";
13 root 1.2 my $RSYNC = "@RSYNC@";
14    
15     use Getopt::Long;
16 root 1.3 use Coro::Event;
17     use AnyEvent;
18     use IO::AIO ();
19 root 1.2 use File::Temp;
20     use Crossfire;
21 root 1.3 use Coro;
22     use Coro::AIO;
23     use POSIX ();
24 root 1.6 use Digest::MD5;
25 root 1.2
26     sub usage {
27     warn <<EOF;
28 root 1.3 Usage: cfutil [-v] [-q] [--force] [--cache]
29 root 1.2 [--install-arch path]
30     [--install-maps maps]
31     [--print-statedir]
32     [--print-confdir]
33     [--print-datadir]
34     [--print-libdir]
35     [--print-bindir]
36     EOF
37     exit 1;
38     }
39    
40     my $VERBOSE = 1;
41 root 1.3 my $CACHE = 0;
42 root 1.2 my $FORCE;
43 root 1.3 my $TMPDIR = "/tmp/cfutil$$~";
44     my $TMPFILE = "aaaa0";
45 root 1.2
46     END { system "rm", "-rf", $TMPDIR }
47    
48 root 1.3 Event->signal (signal => "INT", cb => sub { exit 1 });
49     Event->signal (signal => "TERM", cb => sub { exit 1 });
50    
51 root 1.2 mkdir $TMPDIR, 0700
52     or die "$TMPDIR: $!";
53    
54 root 1.3 sub fork_sub(&) {
55     my ($cb) = @_;
56    
57     if (my $pid = fork) {
58     my $current = $Coro::current;
59     my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
60     Coro::schedule;
61     } else {
62     eval { $cb->() };
63     POSIX::_exit 0 unless $@;
64     warn $@;
65     POSIX::_exit 1;
66     }
67     }
68    
69 root 1.2 sub inst_maps($) {
70     my (undef, $path) = @_;
71    
72 root 1.13 print "installing '$path' to '$DATADIR/maps'\n";
73 root 1.2
74     if (!-f "$path/regions") {
75     warn "'$path' does not look like a maps directory ('regions' file is missing).\n";
76     exit 1 unless $FORCE;
77     }
78    
79 root 1.13 system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded"
80 root 1.16 and die "map installation failed.\n";
81 root 1.13
82     print "maps installed successfully.\n";
83 root 1.2 }
84    
85     {
86 root 1.6 our %PNG32;
87     our %FACEINFO;
88 root 1.3 our @ARC;
89 root 1.12 our $TRS;
90 root 1.3 our $NFILE;
91 root 1.6 our %ANIM;
92 root 1.3
93     our (@png, @trs, @arc); # files we are interested in
94 root 1.2
95     sub commit_png {
96     my ($name, $data) = @_;
97 root 1.5
98 root 1.6 $PNG32{$name} = $data;
99     $FACEINFO{$name} ||= {};
100 root 1.2 }
101    
102 root 1.3 sub process_png {
103     while (@png) {
104     my $path = pop @png;
105 root 1.2
106 root 1.3 my $png;
107     aio_lstat $path;
108 root 1.2 my ($size, $mtime) = (stat _)[7,9];
109    
110 root 1.3 if (0 > aio_load $path, $png) {
111     warn "$path: $!, skipping.\n";
112 root 1.5 next;
113 root 1.3 }
114    
115 root 1.6 # quickly extract width and height of the (necessarily PNG) image
116 root 1.3 unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
117     warn "$path: not a recongized png file, skipping.\n";
118 root 1.5 next;
119 root 1.3 }
120 root 1.2
121 root 1.3 my ($w, $h) = unpack "NN", $1;
122 root 1.2
123 root 1.3 (my $face = $path) =~ s/^.*\///;
124     my $T = 32;
125 root 1.2
126 root 1.3 unless ($face =~ s/\.base\.(...)\.png$/.$1/) {
127     warn "$path: weird filename, skipping.\n";
128 root 1.5 next;
129 root 1.3 }
130 root 1.2
131 root 1.3 if ($w < $T || $h < $T) {
132     warn "$path: too small ($w $h), skipping.\n";
133 root 1.5 next;
134 root 1.3 }
135    
136     if ($w % $T || $h % $T) {
137     warn "$path: weird png size ($w $h), skipping.\n";
138 root 1.5 next;
139 root 1.3 }
140 root 1.2
141 root 1.3 if (($w > $T || $h > $T) && $face !~ /_S\./) {
142     # split
143     my @tile;
144     for my $x (0 .. (int $w / $T) - 1) {
145     for my $y (0 .. (int $h / $T) - 1) {
146     my $file = "$path+$x+$y~";
147     aio_lstat $file;
148     push @tile, [$x, $y, $file, (stat _)[9]];
149     }
150 root 1.2 }
151    
152 root 1.3 my $mtime = (lstat $path)[9];
153     my @todo = grep { $_->[3] <= $mtime } @tile;
154     if (@todo) {
155     fork_sub {
156     open my $convert, "|-", $CONVERT,
157     "png:-",
158     (map {
159     (
160     "(",
161     "+clone",
162     -crop => (sprintf "%dx%d+%d+%d", $T, $T, $_->[0] * $T, $_->[1] * $T),
163 root 1.7 "+repage",
164 root 1.3 -write => "png:$_->[2]~",
165     "+delete",
166     ")",
167     )
168     } @todo),
169     "null:";
170    
171     binmode $convert;
172     print $convert $png;
173     close $convert;
174    
175     # pass 2, optimise, and rename
176     for (@todo) {
177     system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";
178     rename "$_->[2]~", $_->[2];
179     }
180     };
181 root 1.2 }
182    
183 root 1.3 for (@tile) {
184     my ($x, $y, $file) = @$_;
185     my $tile;
186    
187     if (0 > aio_load $file, $tile) {
188     die "$path: unable to read tile +$x+$y, aborting.\n";
189     }
190     IO::AIO::aio_unlink $file unless $CACHE;
191     commit_png $x|$y ? "$face+$x+$y" : $face, $tile;
192 root 1.2 }
193 root 1.3 } else {
194     # use as-is (either small, use smooth)
195     commit_png $face, $png;
196     }
197     }
198 root 1.2 }
199    
200 root 1.3 sub process_arc {
201     while (@arc) {
202     my ($dir, $file) = @{pop @arc};
203 root 1.2
204 root 1.3 my $arc;
205     aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
206 root 1.4
207 root 1.2 my $arc = read_arch "$dir/$file";
208 root 1.4 for my $o (values %$arc) {
209     push @ARC, $o;
210 root 1.6
211 root 1.10 $o->{editor_folder} = $dir;
212    
213 root 1.6 my $visibility = delete $o->{visibility};
214     my $magicmap = delete $o->{magicmap};
215    
216     # find upper left corner :/
217     # omg, this is sooo broken
218 root 1.4 my ($dx, $dy);
219     for (my $o = $o; $o; $o = $o->{more}) {
220     $dx = $o->{x} if $o->{x} < $dx;
221     $dy = $o->{y} if $o->{y} < $dy;
222     }
223 root 1.6
224 root 1.4 for (my $o = $o; $o; $o = $o->{more}) {
225     my $x = $o->{x} - $dx;
226     my $y = $o->{y} - $dy;
227 root 1.6
228     my $ext = $x|$y ? "+$x+$y" : "";
229    
230 root 1.9 $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/;
231 root 1.6
232     my $visibility = delete $o->{visibility} if exists $o->{visibility};
233     my $magicmap = delete $o->{magicmap} if exists $o->{magicmap};
234    
235     my $anim = delete $o->{anim};
236    
237     if ($anim) {
238 root 1.8 $o->{animation} = "$o->{_name}";
239 root 1.6
240     for (@$anim) {
241 root 1.9 $_ .= $ext unless /^facings\s|^blank.x11$|^empty.x11$/;
242 root 1.6 }
243    
244     $ANIM{"$o->{_name}$ext"} =
245     join "", map "$_\n",
246 root 1.8 "anim $o->{_name}",
247 root 1.6 @$anim,
248     "mina";
249     }
250    
251     for my $face ($o->{face} || (), @{$anim || []}) {
252 root 1.9 next if $face =~ /^facings\s|^blank.x11$|^empty.x11$/;
253 root 1.6
254     my $info = $FACEINFO{$face} ||= {};
255    
256     $info->{visibility} = $visibility if defined $visibility;
257     $info->{magicmap} = $magicmap if defined $magicmap;
258 root 1.4 }
259 root 1.12
260     if (my $smooth = delete $o->{smoothface}) {
261 root 1.14 my ($face, $smooth) = split /\s+/, $smooth;
262     # skip empty_S.x11, it seems to server no purpose whatsoever
263     # but increases bandwidth demands and worse.
264     unless ($smooth eq "empty_S.x11") {
265     $FACEINFO{$face}{smooth} = $smooth;
266     }
267 root 1.12 }
268 root 1.4 }
269     }
270 root 1.3 }
271 root 1.2 }
272    
273 root 1.3 sub process_trs {
274     while (@trs) {
275     my ($dir, $file) = @{pop @trs};
276 root 1.12 my $path = "$dir/$file";
277    
278     my $trs;
279     if (0 > aio_load $path, $trs) {
280     warn "$path: $!, skipping.\n";
281     next;
282     }
283    
284     $TRS .= $trs;
285 root 1.3 }
286 root 1.2 }
287    
288 root 1.3 sub find_files;
289     sub find_files {
290 root 1.2 my ($path) = @_;
291    
292 root 1.3 IO::AIO::aioreq_pri 4;
293     IO::AIO::aio_scandir $path, 4, sub {
294 root 1.2 my ($dirs, $nondirs) = @_;
295    
296 root 1.3 find_files "$path/$_"
297 root 1.2 for grep $_ !~ /^(?:CVS|dev)$/, @$dirs;
298    
299     for my $file (@$nondirs) {
300     if ($file =~ /\.png$/) {
301 root 1.3 push @png, "$path/$file";
302 root 1.2 } elsif ($file =~ /\.trs$/) {
303 root 1.3 push @trs, [$path, $file];
304 root 1.2 } elsif ($file =~ /\.arc$/) {
305 root 1.3 push @arc, [$path, $file];
306 root 1.2 } else {
307     warn "ignoring $path/$file\n" if $VERBOSE >= 2;
308     }
309     }
310     };
311     }
312    
313     sub inst_arch($) {
314     my (undef, $path) = @_;
315    
316 root 1.13 print "installing '$path' to '$DATADIR'\n";
317 root 1.2
318     if (!-d "$path/treasures") {
319     warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
320     exit 1 unless $FORCE;
321     }
322    
323 root 1.3 find_files $path;
324 root 1.2 IO::AIO::flush;
325    
326 root 1.3 $_->join for (
327     (async \&process_png), (async \&process_png),
328     (async \&process_trs), (async \&process_trs),
329     (async \&process_arc), (async \&process_arc),
330     );
331    
332 root 1.5 {
333     open my $fh, ">:utf8", "$DATADIR/animations~"
334     or die "$DATADIR/animations~: $!";
335 root 1.6 print $fh join "", map $ANIM{$_}, sort keys %ANIM
336 root 1.5 }
337    
338     {
339     open my $fh, ">:utf8", "$DATADIR/archetypes~"
340     or die "$DATADIR/archetypes~: $!";
341 root 1.11 substr $_->{editor_folder}, 0, 1 + length $path, "" for @ARC;
342 root 1.5 print $fh Crossfire::archlist_to_string \@ARC;
343     }
344    
345 root 1.6 {
346 root 1.12 open my $fh, ">:utf8", "$DATADIR/treasures~"
347     or die "$DATADIR/treasures~: $!";
348     print $fh $TRS;
349     }
350    
351     {
352 root 1.6 while (my ($k, $v) = each %FACEINFO) {
353     $v->{data32} ||= delete $PNG32{$k};
354     }
355    
356     while (my ($k, $v) = each %FACEINFO) {
357 root 1.12 length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
358 root 1.5
359 root 1.6 $v->{chksum32} = Digest::MD5::md5 $v->{data32};
360     }
361    
362     open my $fh, ">:perlio", "$DATADIR/faces~"
363     or die "$DATADIR/faces~: $!";
364    
365 root 1.15 $FACEINFO{""} = { version => 1};
366 root 1.6 print $fh Storable::nfreeze \%FACEINFO;
367 root 1.5 }
368    
369 root 1.14 for (qw(archetypes faces animations treasures)) {
370 root 1.6 chmod 0644, "$DATADIR/$_~";
371 root 1.13 rename "$DATADIR/$_~", "$DATADIR/$_"
372     or die "$DATADIR/$_: $!";
373 root 1.6 }
374 root 1.13
375     print "archetype data installed successfully.\n";
376 root 1.2 }
377     }
378    
379     Getopt::Long::Configure ("bundling", "no_ignore_case");
380     GetOptions (
381     "verbose|v:+" => \$VERBOSE,
382 root 1.3 "cache" => \$CACHE,
383 root 1.2 "quiet|q" => sub { $VERBOSE = 0 },
384     "force" => sub { $FORCE = 1 },
385     "install-arch=s" => \&inst_arch,
386     "install-maps=s" => \&inst_maps,
387     "print-statedir" => sub { print "@pkgstatedir@\n" },
388     "print-datadir" => sub { print "$DATADIR\n" },
389     "print-confdir" => sub { print "@pkgconfdir@\n" },
390     "print-libdir" => sub { print "@libdir@/@PACKAGE@\n" },
391     "print-bindir" => sub { print "@bindir@/@PACKAGE@\n" },
392     ) or usage;
393