--- deliantra/server/utils/cfutil.in	2007/03/07 01:23:37	1.2
+++ deliantra/server/utils/cfutil.in	2007/03/07 20:30:18	1.4
@@ -9,16 +9,22 @@
 
 my $CONVERT  = "@CONVERT@";
 my $IDENTIFY = "@IDENTIFY@";
+my $OPTIPNG  = "@OPTIPNG@";
 my $RSYNC    = "@RSYNC@";
 
 use Getopt::Long;
-use IO::AIO;
+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]
+Usage: cfutil [-v] [-q] [--force] [--cache]
               [--install-arch path]
               [--install-maps maps]
               [--print-statedir]
@@ -31,14 +37,34 @@
 }
 
 my $VERBOSE = 1;
+my $CACHE = 0;
 my $FORCE;
-my $TMPDIR = "/tmp/cfutil$$~";
+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) = @_;
 
@@ -53,97 +79,165 @@
 }
 
 {
-   my @PNG;
-   my @ARC;
+   our @PNG;
+   our @ARC;
+   our $NFILE;
+
+   our (@png, @trs, @arc); # files we are interested in
 
    sub commit_png {
       my ($name, $data) = @_;
       #warn "$name: commited\n";
    }
 
-   sub add_png($) {
-      my ($path) = @_;
+   sub process_png {
+      while (@png) {
+         my $path = pop @png;
 
-      my $png;
-      aio_lstat $path, sub {
+         my $png;
+         aio_lstat $path;
          my ($size, $mtime) = (stat _)[7,9];
 
-         aio_load $path, $png, sub {
-            if ($_[0] < 0) {
-               warn "$path: $!, skipping.\n";
-               return;
-            }
+         if (0 > aio_load $path, $png) {
+            warn "$path: $!, skipping.\n";
+            return;
+         }
 
-            unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
-               warn "$path: not a recongized png file, skipping.\n";
-               return;
-            }
+         # 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";
+            return;
+         }
 
-            my ($w, $h) = unpack "NN", $1;
+         my ($w, $h) = unpack "NN", $1;
 
-            (my $face = $path) =~ s/^.*\///;
-            my $T = 32;
+         (my $face = $path) =~ s/^.*\///;
+         my $T = 32;
 
-            unless ($face =~ s/\.base\.(...)\.png$/.$1/) {
-               warn "$path: weird filename, skipping.\n";
-               return;
-            }
+         unless ($face =~ s/\.base\.(...)\.png$/.$1/) {
+            warn "$path: weird filename, skipping.\n";
+            return;
+         }
 
-            if ($w < $T || $h < $T) {
-               warn "$path: too small ($w $h), skipping.\n";
-               return;
-            }
+         if ($w < $T || $h < $T) {
+            warn "$path: too small ($w $h), skipping.\n";
+            return;
+         }
 
-            if ($w % $T || $h % $T) {
-               warn "$path: weird png size ($w $h), skipping.\n";
-               return;
-            }
+         if ($w % $T || $h % $T) {
+            warn "$path: weird png size ($w $h), skipping.\n";
+            return;
+         }
 
-            if ($w > $T || $h > $T) {
-               # split
-            } else {
-               # use as-is
-               commit_png $face, $png;
+         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]];
+               }
             }
 
-            #warn "$path: $w, $h\n";
-         };
-      };
+            my $mtime = (lstat $path)[9];
+            my @todo = grep { $_->[3] <= $mtime } @tile;
+            if (@todo) {
+               fork_sub {
+                  open my $convert, "|-", $CONVERT,
+                     "png:-",
+                     (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];
+                  }
+               };
+            }
 
-      IO::AIO::poll; # reduce file-handle pressure
+            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 add_arc($$) {
-      my ($dir, $file) = @_;
+   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;
-      aio_load "$dir/$file", $arc, sub { # 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} || []};
+               }
+            }
+         }
+      }
    }
 
-   sub add_trs($$) {
-      my ($dir, $file) = @_;
+   sub process_trs {
+      while (@trs) {
+         my ($dir, $file) = @{pop @trs};
+      }
    }
 
-   sub collect_arch;
-   sub collect_arch {
+   sub find_files;
+   sub find_files {
       my ($path) = @_;
 
-      aioreq_pri 4;
-      aio_scandir $path, 4, sub {
+      IO::AIO::aioreq_pri 4;
+      IO::AIO::aio_scandir $path, 4, sub {
          my ($dirs, $nondirs) = @_;
 
-         collect_arch "$path/$_"
+         find_files "$path/$_"
             for grep $_ !~ /^(?:CVS|dev)$/, @$dirs;
 
          for my $file (@$nondirs) {
             if ($file =~ /\.png$/) {
-               add_png "$path/$file";
+               push @png, "$path/$file";
             } elsif ($file =~ /\.trs$/) {
-               add_trs $path, $file;
+               push @trs, [$path, $file];
             } elsif ($file =~ /\.arc$/) {
-               add_arc $path, $file;
+               push @arc, [$path, $file];
             } else {
                warn "ignoring $path/$file\n" if $VERBOSE >= 2;
             }
@@ -161,16 +255,29 @@
          exit 1 unless $FORCE;
       }
 
-      collect_arch $path;
+      find_files $path;
       IO::AIO::flush;
 
-      die "--install-arch not yet implemented\n";
+      $_->join for (
+         (async \&process_png), (async \&process_png),
+         (async \&process_trs), (async \&process_trs),
+         (async \&process_arc), (async \&process_arc),
+      );
+
+      open my $archetypes, ">:utf8", "$DATADIR/archetypes~"
+         or die "$DATADIR/archetypes~: $!";
+      print $archetypes Crossfire::archlist_to_string \@ARC;
+      close $archetypes;
+      rename "$DATADIR/archetypes~", "$DATADIR/archetypes";
+
+      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,