server/utils/cfutil.in

#!@PERL@

use strict;

my $prefix      = "@prefix@";
my $exec_prefix = "@exec_prefix@";
my $datarootdir = "@datarootdir@";
my $DATADIR     = "@datadir@/@PACKAGE@";

my $CONVERT  = "@CONVERT@";
my $IDENTIFY = "@IDENTIFY@";
my $OPTIPNG  = "@OPTIPNG@";
my $RSYNC    = "@RSYNC@";

use Getopt::Long;
use Coro::Event;
use AnyEvent;
use IO::AIO ();
use File::Temp;
use Crossfire;
use Coro;
use Coro::AIO;
use POSIX ();

sub usage {
   warn <<EOF;
Usage: cfutil [-v] [-q] [--force] [--cache]
              [--install-arch path]
              [--install-maps maps]
              [--print-statedir]
              [--print-confdir]
              [--print-datadir]
              [--print-libdir]
              [--print-bindir]
EOF
   exit 1;
}

my $VERBOSE = 1;
my $CACHE = 0;
my $FORCE;
my $TMPDIR  = "/tmp/cfutil$$~";
my $TMPFILE = "aaaa0";

END { system "rm", "-rf", $TMPDIR }

Event->signal (signal => "INT",  cb => sub { exit 1 });
Event->signal (signal => "TERM", cb => sub { exit 1 });

mkdir $TMPDIR, 0700
   or die "$TMPDIR: $!";

sub fork_sub(&) {
   my ($cb) = @_;

   if (my $pid = fork) {
      my $current = $Coro::current;
      my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
      Coro::schedule;
   } else {
      eval { $cb->() };
      POSIX::_exit 0 unless $@;
      warn $@;
      POSIX::_exit 1;
   }
}

sub inst_maps($) {
   my (undef, $path) = @_;

   print "installing '$path' to '$DATADIR/maps'\n\n";

   if (!-f "$path/regions") {
      warn "'$path' does not look like a maps directory ('regions' file is missing).\n";
      exit 1 unless $FORCE;
   }

   system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded";
}

{
   our @PNG;
   our @ARC;
   our $NFILE;
   our @FACE;
   our $ANIM;

   our (@png, @trs, @arc); # files we are interested in

   sub commit_png {
      my ($name, $data) = @_;

      push @PNG, [$name => $data];
   }

   sub process_png {
      while (@png) {
         my $path = pop @png;

         my $png;
         aio_lstat $path;
         my ($size, $mtime) = (stat _)[7,9];

         if (0 > aio_load $path, $png) {
            warn "$path: $!, skipping.\n";
            next;
         }

         # quickly extratc width and height of the (necessarily PNG) image
         unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
            warn "$path: not a recongized png file, skipping.\n";
            next;
         }

         my ($w, $h) = unpack "NN", $1;

         (my $face = $path) =~ s/^.*\///;
         my $T = 32;

         unless ($face =~ s/\.base\.(...)\.png$/.$1/) {
            warn "$path: weird filename, skipping.\n";
            next;
         }

         if ($w < $T || $h < $T) {
            warn "$path: too small ($w $h), skipping.\n";
            next;
         }

         if ($w % $T || $h % $T) {
            warn "$path: weird png size ($w $h), skipping.\n";
            next;
         }

         if (($w > $T || $h > $T) && $face !~ /_S\./) {
            # split
            my @tile;
            for my $x (0 .. (int $w / $T) - 1) {
               for my $y (0 .. (int $h / $T) - 1) {
                  my $file = "$path+$x+$y~";
                  aio_lstat $file;
                  push @tile, [$x, $y, $file, (stat _)[9]];
               }
            }

            my $mtime = (lstat $path)[9];
            my @todo = grep { $_->[3] <= $mtime } @tile;
            if (@todo) {
               fork_sub {
                  open my $convert, "|-", $CONVERT,
                     "png:-",
                     -negate,#d#
                     (map {
                        (
                           "(",
                           "+clone",
                           -crop => (sprintf "%dx%d+%d+%d", $T, $T, $_->[0] * $T, $_->[1] * $T),
                           -write => "png:$_->[2]~",
                           "+delete",
                           ")",
                        )
                     } @todo),
                     "null:";

                  binmode $convert;
                  print $convert $png;
                  close $convert;

                  # pass 2, optimise, and rename
                  for (@todo) {
                     system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";
                     rename "$_->[2]~", $_->[2];
                  }
               };
            }

            for (@tile) {
               my ($x, $y, $file) = @$_;
               my $tile;

               if (0 > aio_load $file, $tile) {
                  die "$path: unable to read tile +$x+$y, aborting.\n";
               }
               IO::AIO::aio_unlink $file unless $CACHE;
               commit_png $x|$y ? "$face+$x+$y" : $face, $tile;
            }
         } else {
            # use as-is (either small, use smooth)
            commit_png $face, $png;
         }
      }
   }

   sub process_arc {
      while (@arc) {
         my ($dir, $file) = @{pop @arc};

         my $arc;
         aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/

         my $arc = read_arch "$dir/$file";
         for my $o (values %$arc) {
            push @ARC, $o;
            my ($dx, $dy);
            # omg, this is sooo broken
            for (my $o = $o; $o; $o = $o->{more}) {
               $dx = $o->{x} if $o->{x} < $dx;
               $dy = $o->{y} if $o->{y} < $dy;
            }
            for (my $o = $o; $o; $o = $o->{more}) {
               my $x = $o->{x} - $dx;
               my $y = $o->{y} - $dy;
               if ($x|$y) {
                  $_ .= "+$x+$y" for $o->{face}, @{$o->{anim} || []};
               }
            }
            if (my $anim = delete $o->{anim}) {
               $o->{animation} = $o->{_name};
               $ANIM .= join "", map "$_\n",
                           "anim $o->{_name}",
                           @$anim,
                           "mina";
            }
         }
      }
   }

   sub process_trs {
      while (@trs) {
         my ($dir, $file) = @{pop @trs};
      }
   }

   sub find_files;
   sub find_files {
      my ($path) = @_;

      IO::AIO::aioreq_pri 4;
      IO::AIO::aio_scandir $path, 4, sub {
         my ($dirs, $nondirs) = @_;

         find_files "$path/$_"
            for grep $_ !~ /^(?:CVS|dev)$/, @$dirs;

         for my $file (@$nondirs) {
            if ($file =~ /\.png$/) {
               push @png, "$path/$file";
            } elsif ($file =~ /\.trs$/) {
               push @trs, [$path, $file];
            } elsif ($file =~ /\.arc$/) {
               push @arc, [$path, $file];
            } else {
               warn "ignoring $path/$file\n" if $VERBOSE >= 2;
            }
         }
      };
   }

   sub inst_arch($) {
      my (undef, $path) = @_;

      print "installing '$path' to '$DATADIR'\n\n";

      if (!-d "$path/treasures") {
         warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
         exit 1 unless $FORCE;
      }

      find_files $path;
      IO::AIO::flush;

      $_->join for (
         (async \&process_png), (async \&process_png),
         (async \&process_trs), (async \&process_trs),
         (async \&process_arc), (async \&process_arc),
      );

      {
         open my $fh, ">:utf8", "$DATADIR/animations~"
            or die "$DATADIR/animations~: $!";
         print $fh $ANIM;
      }

      {
         open my $fh, ">:utf8", "$DATADIR/archetypes~"
            or die "$DATADIR/archetypes~: $!";
         print $fh Crossfire::archlist_to_string \@ARC;
      }

      @PNG = sort { $a->[0] cmp $b->[0] } @PNG;

      {
         open my $fh, ">:perlio", "$DATADIR/crossfire.0~"
            or die "$DATADIR/crossfire.0~: $!";
         printf $fh "IMAGE %d %d %s\x0a%s", $_, (length $PNG[$_][1]), $PNG[$_][0], $PNG[$_][1]
            for 0.. $#PNG;
      }

      rename "$DATADIR/archetypes~" , "$DATADIR/archetypes";
      rename "$DATADIR/crossfire.0~", "$DATADIR/crossfire.0";
      rename "$DATADIR/animations~" , "$DATADIR/animations";

      die "--install-arch not fully implemented\n";
   }
}

Getopt::Long::Configure ("bundling", "no_ignore_case");
GetOptions (
   "verbose|v:+"    => \$VERBOSE,
   "cache"          => \$CACHE,
   "quiet|q"        => sub { $VERBOSE = 0 },
   "force"          => sub { $FORCE = 1 },
   "install-arch=s" => \&inst_arch,
   "install-maps=s" => \&inst_maps,
   "print-statedir" => sub { print "@pkgstatedir@\n" },
   "print-datadir"  => sub { print "$DATADIR\n" },
   "print-confdir"  => sub { print "@pkgconfdir@\n" },
   "print-libdir"   => sub { print "@libdir@/@PACKAGE@\n" },
   "print-bindir"   => sub { print "@bindir@/@PACKAGE@\n" },
) or usage;

Revision:	1.5
Committed:	Thu Mar 8 15:19:08 2007 UTC (17 years, 2 months ago) by root
Branch:	MAIN
Changes since 1.4:	+41 -11 lines
Log Message:	closer, now the server needs a more modern approach Two monks were watching a flag flapping in the wind. One said to the other, "The flag is moving." The other replied, "The wind is moving." Huineng overheard this. He said, "Not the flag, not the wind; mind is moving."
#	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.2
25			sub usage {
26			warn <<EOF;
27	root	1.3	Usage: cfutil [-v] [-q] [--force] [--cache]
28	root	1.2	[--install-arch path]
29			[--install-maps maps]
30			[--print-statedir]
31			[--print-confdir]
32			[--print-datadir]
33			[--print-libdir]
34			[--print-bindir]
35			EOF
36			exit 1;
37			}
38
39			my $VERBOSE = 1;
40	root	1.3	my $CACHE = 0;
41	root	1.2	my $FORCE;
42	root	1.3	my $TMPDIR = "/tmp/cfutil$$~";
43			my $TMPFILE = "aaaa0";
44	root	1.2
45			END { system "rm", "-rf", $TMPDIR }
46
47	root	1.3	Event->signal (signal => "INT", cb => sub { exit 1 });
48			Event->signal (signal => "TERM", cb => sub { exit 1 });
49
50	root	1.2	mkdir $TMPDIR, 0700
51			or die "$TMPDIR: $!";
52
53	root	1.3	sub fork_sub(&) {
54			my ($cb) = @_;
55
56			if (my $pid = fork) {
57			my $current = $Coro::current;
58			my $w = AnyEvent->child (pid => $pid, cb => sub { $current->ready });
59			Coro::schedule;
60			} else {
61			eval { $cb->() };
62			POSIX::_exit 0 unless $@;
63			warn $@;
64			POSIX::_exit 1;
65			}
66			}
67
68	root	1.2	sub inst_maps($) {
69			my (undef, $path) = @_;
70
71			print "installing '$path' to '$DATADIR/maps'\n\n";
72
73			if (!-f "$path/regions") {
74			warn "'$path' does not look like a maps directory ('regions' file is missing).\n";
75			exit 1 unless $FORCE;
76			}
77
78			system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded";
79			}
80
81			{
82	root	1.3	our @PNG;
83			our @ARC;
84			our $NFILE;
85	root	1.5	our @FACE;
86			our $ANIM;
87	root	1.3
88			our (@png, @trs, @arc); # files we are interested in
89	root	1.2
90			sub commit_png {
91			my ($name, $data) = @_;
92	root	1.5
93			push @PNG, [$name => $data];
94	root	1.2	}
95
96	root	1.3	sub process_png {
97			while (@png) {
98			my $path = pop @png;
99	root	1.2
100	root	1.3	my $png;
101			aio_lstat $path;
102	root	1.2	my ($size, $mtime) = (stat _)[7,9];
103
104	root	1.3	if (0 > aio_load $path, $png) {
105			warn "$path: $!, skipping.\n";
106	root	1.5	next;
107	root	1.3	}
108
109			# quickly extratc width and height of the (necessarily PNG) image
110			unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
111			warn "$path: not a recongized png file, skipping.\n";
112	root	1.5	next;
113	root	1.3	}
114	root	1.2
115	root	1.3	my ($w, $h) = unpack "NN", $1;
116	root	1.2
117	root	1.3	(my $face = $path) =~ s/^.*\///;
118			my $T = 32;
119	root	1.2
120	root	1.3	unless ($face =~ s/\.base\.(...)\.png$/.$1/) {
121			warn "$path: weird filename, skipping.\n";
122	root	1.5	next;
123	root	1.3	}
124	root	1.2
125	root	1.3	if ($w < $T \|\| $h < $T) {
126			warn "$path: too small ($w $h), skipping.\n";
127	root	1.5	next;
128	root	1.3	}
129
130			if ($w % $T \|\| $h % $T) {
131			warn "$path: weird png size ($w $h), skipping.\n";
132	root	1.5	next;
133	root	1.3	}
134	root	1.2
135	root	1.3	if (($w > $T \|\| $h > $T) && $face !~ /_S\./) {
136			# split
137			my @tile;
138			for my $x (0 .. (int $w / $T) - 1) {
139			for my $y (0 .. (int $h / $T) - 1) {
140			my $file = "$path+$x+$y~";
141			aio_lstat $file;
142			push @tile, [$x, $y, $file, (stat _)[9]];
143			}
144	root	1.2	}
145
146	root	1.3	my $mtime = (lstat $path)[9];
147			my @todo = grep { $_->[3] <= $mtime } @tile;
148			if (@todo) {
149			fork_sub {
150			open my $convert, "\|-", $CONVERT,
151			"png:-",
152	root	1.5	-negate,#d#
153	root	1.3	(map {
154			(
155			"(",
156			"+clone",
157			-crop => (sprintf "%dx%d+%d+%d", $T, $T, $_->[0] * $T, $_->[1] * $T),
158			-write => "png:$_->[2]~",
159			"+delete",
160			")",
161			)
162			} @todo),
163			"null:";
164
165			binmode $convert;
166			print $convert $png;
167			close $convert;
168
169			# pass 2, optimise, and rename
170			for (@todo) {
171			system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";
172			rename "$_->[2]~", $_->[2];
173			}
174			};
175	root	1.2	}
176
177	root	1.3	for (@tile) {
178			my ($x, $y, $file) = @$_;
179			my $tile;
180
181			if (0 > aio_load $file, $tile) {
182			die "$path: unable to read tile +$x+$y, aborting.\n";
183			}
184			IO::AIO::aio_unlink $file unless $CACHE;
185			commit_png $x\|$y ? "$face+$x+$y" : $face, $tile;
186	root	1.2	}
187	root	1.3	} else {
188			# use as-is (either small, use smooth)
189			commit_png $face, $png;
190			}
191			}
192	root	1.2	}
193
194	root	1.3	sub process_arc {
195			while (@arc) {
196			my ($dir, $file) = @{pop @arc};
197	root	1.2
198	root	1.3	my $arc;
199			aio_load "$dir/$file", $arc; # simply pre-cache, as read_arch wants a file :/
200	root	1.4
201	root	1.2	my $arc = read_arch "$dir/$file";
202	root	1.4	for my $o (values %$arc) {
203			push @ARC, $o;
204			my ($dx, $dy);
205			# omg, this is sooo broken
206			for (my $o = $o; $o; $o = $o->{more}) {
207			$dx = $o->{x} if $o->{x} < $dx;
208			$dy = $o->{y} if $o->{y} < $dy;
209			}
210			for (my $o = $o; $o; $o = $o->{more}) {
211			my $x = $o->{x} - $dx;
212			my $y = $o->{y} - $dy;
213			if ($x\|$y) {
214			$_ .= "+$x+$y" for $o->{face}, @{$o->{anim} \|\| []};
215			}
216			}
217	root	1.5	if (my $anim = delete $o->{anim}) {
218			$o->{animation} = $o->{_name};
219			$ANIM .= join "", map "$_\n",
220			"anim $o->{_name}",
221			@$anim,
222			"mina";
223			}
224	root	1.4	}
225	root	1.3	}
226	root	1.2	}
227
228	root	1.3	sub process_trs {
229			while (@trs) {
230			my ($dir, $file) = @{pop @trs};
231			}
232	root	1.2	}
233
234	root	1.3	sub find_files;
235			sub find_files {
236	root	1.2	my ($path) = @_;
237
238	root	1.3	IO::AIO::aioreq_pri 4;
239			IO::AIO::aio_scandir $path, 4, sub {
240	root	1.2	my ($dirs, $nondirs) = @_;
241
242	root	1.3	find_files "$path/$_"
243	root	1.2	for grep $_ !~ /^(?:CVS\|dev)$/, @$dirs;
244
245			for my $file (@$nondirs) {
246			if ($file =~ /\.png$/) {
247	root	1.3	push @png, "$path/$file";
248	root	1.2	} elsif ($file =~ /\.trs$/) {
249	root	1.3	push @trs, [$path, $file];
250	root	1.2	} elsif ($file =~ /\.arc$/) {
251	root	1.3	push @arc, [$path, $file];
252	root	1.2	} else {
253			warn "ignoring $path/$file\n" if $VERBOSE >= 2;
254			}
255			}
256			};
257			}
258
259			sub inst_arch($) {
260			my (undef, $path) = @_;
261
262			print "installing '$path' to '$DATADIR'\n\n";
263
264			if (!-d "$path/treasures") {
265			warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
266			exit 1 unless $FORCE;
267			}
268
269	root	1.3	find_files $path;
270	root	1.2	IO::AIO::flush;
271
272	root	1.3	$_->join for (
273			(async \&process_png), (async \&process_png),
274			(async \&process_trs), (async \&process_trs),
275			(async \&process_arc), (async \&process_arc),
276			);
277
278	root	1.5	{
279			open my $fh, ">:utf8", "$DATADIR/animations~"
280			or die "$DATADIR/animations~: $!";
281			print $fh $ANIM;
282			}
283
284			{
285			open my $fh, ">:utf8", "$DATADIR/archetypes~"
286			or die "$DATADIR/archetypes~: $!";
287			print $fh Crossfire::archlist_to_string \@ARC;
288			}
289
290			@PNG = sort { $a->[0] cmp $b->[0] } @PNG;
291
292			{
293			open my $fh, ">:perlio", "$DATADIR/crossfire.0~"
294			or die "$DATADIR/crossfire.0~: $!";
295			printf $fh "IMAGE %d %d %s\x0a%s", $_, (length $PNG[$_][1]), $PNG[$_][0], $PNG[$_][1]
296			for 0.. $#PNG;
297			}
298
299			rename "$DATADIR/archetypes~" , "$DATADIR/archetypes";
300			rename "$DATADIR/crossfire.0~", "$DATADIR/crossfire.0";
301			rename "$DATADIR/animations~" , "$DATADIR/animations";
302	root	1.4
303			die "--install-arch not fully implemented\n";
304	root	1.2	}
305			}
306
307			Getopt::Long::Configure ("bundling", "no_ignore_case");
308			GetOptions (
309			"verbose\|v:+" => \$VERBOSE,
310	root	1.3	"cache" => \$CACHE,
311	root	1.2	"quiet\|q" => sub { $VERBOSE = 0 },
312			"force" => sub { $FORCE = 1 },
313			"install-arch=s" => \&inst_arch,
314			"install-maps=s" => \&inst_maps,
315			"print-statedir" => sub { print "@pkgstatedir@\n" },
316			"print-datadir" => sub { print "$DATADIR\n" },
317			"print-confdir" => sub { print "@pkgconfdir@\n" },
318			"print-libdir" => sub { print "@libdir@/@PACKAGE@\n" },
319			"print-bindir" => sub { print "@bindir@/@PACKAGE@\n" },
320			) or usage;
321