ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/deliantra/server/utils/cfutil.in
Revision: 1.12
Committed: Mon Mar 12 17:26:41 2007 UTC (17 years, 2 months ago) by root
Branch: MAIN
Changes since 1.11: +29 -6 lines
Log Message:
try to switch over to cfutil - cfutil willnow be built and install, should mostly work, and files should not get overwritten by make install

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