--- deliantra/server/utils/cfutil.in	2007/03/07 01:23:37	1.2
+++ deliantra/server/utils/cfutil.in	2007/04/21 11:55:36	1.30
@@ -9,16 +9,24 @@
 
 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 ();
+use Digest::MD5;
+use Coro::Storable; $Storable::canonical = 1;
 
 sub usage {
    warn <<EOF;
-Usage: cfutil [-v] [-q] [--force]
+Usage: cfutil [-v] [-q] [--force] [--cache]
               [--install-arch path]
               [--install-maps maps]
               [--print-statedir]
@@ -31,119 +39,335 @@
 }
 
 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) = @_;
 
-   print "installing '$path' to '$DATADIR/maps'\n\n";
+   print "\nInstalling '$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";
+   system $RSYNC, "-av", "$path/.", "$DATADIR/maps/.", "--delete", "--exclude", "CVS", "--delete-excluded"
+      and die "map installation failed.\n";
+
+   print "maps installed successfully.\n";
 }
 
 {
-   my @PNG;
-   my @ARC;
+   our %ANIMINFO;
+   our %FACEINFO;
+   our @ARC;
+   our %ARC;
+   our $TRS;
+   our $NFILE;
+
+   our $QUANTIZE = "+dither -colorspace RGB -colors 256";
+
+   our (@png, @trs, @arc); # files we are interested in
 
-   sub commit_png {
-      my ($name, $data) = @_;
-      #warn "$name: commited\n";
+   sub commit_png($$$) {
+      my ($name, $data, $T) = @_;
+
+      $FACEINFO{$name}{"data$T"} = $data;
    }
 
-   sub add_png($) {
-      my ($path) = @_;
+   sub process_png {
+      while (@png) {
+         my ($path, $delete) = @{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";
+            next;
+         }
 
-            unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
-               warn "$path: not a recongized png file, skipping.\n";
-               return;
-            }
+         my $stem = $path;
+         my $T;
+
+         if ($stem =~ s/\.32x32\.png~?$//) {
+            $T = 32;
+         } elsif ($stem =~ s/\.64x64\.png~?$//) {
+            $T = 64;
+         } else {
+            warn "$path: weird filename, skipping.\n";
+            next;
+         }
+
+         # quickly extract width and height of the (necessarily PNG) image
+         unless ($png =~ /^\x89PNG\x0d\x0a\x1a\x0a....IHDR(........)/s) {
+            warn "$path: not a recognized png file, skipping.\n";
+            next;
+         }
+
+         my ($w, $h) = unpack "NN", $1;
+
+         if ($w < $T || $h < $T) {
+            warn "$path: too small ($w $h), skipping.\n";
+            next;
+         }
 
-            my ($w, $h) = unpack "NN", $1;
+         if ($w % $T || $h % $T) {
+            warn "$path: weird png size ($w $h), skipping.\n";
+            next;
+         }
 
-            (my $face = $path) =~ s/^.*\///;
-            my $T = 32;
+         unless ($path =~ /~$/) {
+            # possibly enlarge
+            if (0 > aio_stat "$stem.64x64.png") {
+               my $other = "$stem.64x64.png~";
+
+               if (0 > aio_lstat $other or (-M _) > (-M $path)) {
+                  my $wrap = 0; # for the time being
+                  fork_sub {
+                     system "convert png:\Q$path\E -depth 8 rgba:-"
+                          . "| $exec_prefix/bin/cfhq2xa $w $h $wrap"
+                          . "| convert -depth 8 -size ".($w * 2)."x".($h * 2)." rgba:- $QUANTIZE -quality 00 png32:\Q$other\E~"
+                             and die "convert/hq2xa pipeline error: status $? ($!)";
+                     system $OPTIPNG, "-o5", "-i0", "-q", "$other~";
+                     die "$other~ has zero size, aborting." unless -s "$other~";
+                     rename "$other~", $other;
+                  };
+               }
 
-            unless ($face =~ s/\.base\.(...)\.png$/.$1/) {
-               warn "$path: weird filename, skipping.\n";
-               return;
+               push @png, [$other, !$CACHE];
             }
 
-            if ($w < $T || $h < $T) {
-               warn "$path: too small ($w $h), skipping.\n";
-               return;
+            # possibly scale down
+            if (0 > aio_stat "$stem.32x32.png") {
+               my $other = "$stem.32x32.png~";
+
+               if (0 > aio_lstat $other or (-M _) > (-M $path)) {
+                  fork_sub {
+                     system "convert png:\Q$path\E -geometry 50% -filter lanczos $QUANTIZE -quality 00 png32:\Q$other\E~";
+                     system $OPTIPNG, "-o5", "-i0", "-q", "$other~";
+                     die "$other~ has zero size, aborting." unless -s "$other~";
+                     rename "$other~", $other;
+                  };
+               }
+
+               #warn "scaled down $path to $other\n";#d#
+               push @png, [$other, !$CACHE];
             }
+         }
+
+         (my $face = $stem) =~ s/^.*\///;
 
-            if ($w % $T || $h % $T) {
-               warn "$path: weird png size ($w $h), skipping.\n";
-               return;
+         # split all bigfaces, but avoid smoothfaces (*_S)
+         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]];
+               }
             }
 
-            if ($w > $T || $h > $T) {
-               # split
-            } else {
-               # use as-is
-               commit_png $face, $png;
+            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),
+                           "+repage",
+                           -quality => "00",
+                           -write => "png32:$_->[2]~",
+                           "+delete",
+                           ")",
+                        )
+                     } @todo),
+                     "null:";
+
+                  binmode $convert;
+                  print $convert $png;
+                  close $convert;
+
+                  # pass 2, optimise, and rename
+                  for (@todo) {
+                     system $OPTIPNG, "-o5", "-i0", "-q", "$_->[2]~";
+                     die "$_->[2]~ has zero size, aborting." unless -s "$_->[2]~";
+                     rename "$_->[2]~", $_->[2];
+                  }
+               };
             }
 
-            #warn "$path: $w, $h\n";
-         };
-      };
+            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, $T;
+            }
+         } else {
+            # use as-is (either small, use smooth)
+            commit_png $face, $png, $T;
+         }
 
-      IO::AIO::poll; # reduce file-handle pressure
+         aio_unlink $path if $delete;
+      }
    }
 
-   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;
+            for (my $m = $o; $m; $m = $m->{more}) {
+               $ARC{$m->{_name}} = $m;
+            }
+
+            $o->{editor_folder} = $dir;
+
+            my $visibility = delete $o->{visibility};
+            my $magicmap   = delete $o->{magicmap};
+
+            # find upper left corner :/
+            # omg, this is sooo broken
+            my ($dx, $dy);
+            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;
+
+               my $ext = $x|$y ? "+$x+$y" : "";
+
+               $o->{face} .= $ext unless /^blank.x11$|^empty.x11$/ || !$o->{face};
+
+               my $visibility = delete $o->{visibility} if exists $o->{visibility};
+               my $magicmap   = delete $o->{magicmap}   if exists $o->{magicmap};
+
+               my $anim = delete $o->{anim};
+
+               if ($anim) {
+                  # possibly add $ext to the animation name to avoid
+                  # the need to specify archnames for all parts
+                  # of a multipart archetype.
+                  $o->{animation} = "$o->{_name}";
+                  my $facings = 1;
+                  my @frames;
+
+                  for (@$anim) {
+                     if (/^facings\s+(\d+)/) {
+                        $facings = $1*1;
+                     } elsif (/^blank.x11$|^empty.x11$/) {
+                        push @frames, $_;
+                     } else {
+                        push @frames, "$_$ext";
+                     }
+                  }
+
+                  $ANIMINFO{$o->{animation}} = {
+                     facings => $facings,
+                     frames  => \@frames,
+                  };
+               }
+
+               for my $face ($o->{face} || (), @{$anim || []}) {
+                  next if $face =~ /^facings\s|^blank.x11$|^empty.x11$/;
+
+                  my $info = $FACEINFO{$face} ||= {};
+
+                  $info->{visibility} = $visibility if defined $visibility;
+                  $info->{magicmap}   = $magicmap   if defined $magicmap;
+               }
+
+               if (my $smooth = delete $o->{smoothface}) {
+                  my %kv =split /\s+/, $smooth;
+                  my $level = $o->{smoothlevel}; #TODO: delete from $o if !gcfclient-support
+                  while (my ($face, $smooth) = each %kv) {
+                     $FACEINFO{$face}{smooth}      = $smooth;
+                     $FACEINFO{$face}{smoothlevel} = $level;
+                  }
+               }
+            }
+         }
+      }
    }
 
-   sub add_trs($$) {
-      my ($dir, $file) = @_;
+   sub process_trs {
+      while (@trs) {
+         my ($dir, $file) = @{pop @trs};
+         my $path = "$dir/$file";
+
+         my $trs;
+         if (0 > aio_load $path, $trs) {
+            warn "$path: $!, skipping.\n";
+            next;
+         }
+
+         $TRS .= $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", 0];
             } 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;
             }
@@ -154,23 +378,115 @@
    sub inst_arch($) {
       my (undef, $path) = @_;
 
-      print "installing '$path' to '$DATADIR'\n\n";
+      print "\n",
+            "Installing '$path' to '$DATADIR'\n",
+            "\n",
+            "This can take a long time if you run this\n",
+            "for the first time or do not use --cache.\n",
+            "\n",
+            "Unless you run verbosely, all following warning\n",
+            "or error messages indicate serious problems.\n",
+            "\n";
 
       if (!-d "$path/treasures") {
          warn "'$path' does not look like an arch directory ('treasures' directory is missing).\n";
          exit 1 unless $FORCE;
       }
 
-      collect_arch $path;
+      find_files $path;
       IO::AIO::flush;
 
-      die "--install-arch not yet implemented\n";
+      $_->join for (
+         # four png crunchers work fine for my 2x smp machine
+         (async \&process_png), (async \&process_png), (async \&process_png), (async \&process_png),
+         (async \&process_trs), (async \&process_trs),
+         (async \&process_arc), (async \&process_arc),
+      );
+
+      {
+         # remove path prefix from editor_folder
+         substr $_->{editor_folder}, 0, 1 + length $path, ""
+            for values %ARC;
+
+         # resolve inherit
+         while () {
+            my $progress;
+            my $loop;
+
+            for my $o (values %ARC) {
+               if (my $other = $o->{inherit}) {
+                  if (my $s = $ARC{$other}) {
+                     if ($s->{inherit}) {
+                        $loop = $s;
+                     } else {
+                        delete $o->{inherit};
+                        my %s = %$s;
+                        delete @s{qw(_name more name name_pl)};
+                        %$o = ( %s, %$o );
+                        ++$progress;
+                     }
+                  } else {
+                     warn "'$o->{_name}' tries to inherit from undefined archetype '$other', skipping.\n";
+                     delete $ARC{$o->{_name}};
+                  }
+               }
+            }
+
+            unless ($progress) {
+               die "inheritance loop detected starting at archetype '$loop->{_name}', aborting.\n"
+                  if $loop;
+
+               last;
+            }
+         }
+
+         open my $fh, ">:utf8", "$DATADIR/archetypes~"
+            or die "$DATADIR/archetypes~: $!";
+         print $fh Crossfire::archlist_to_string [sort { $a->{_name} cmp $b->{_name} } @ARC];
+      }
+
+      {
+         open my $fh, ">:utf8", "$DATADIR/treasures~"
+            or die "$DATADIR/treasures~: $!";
+         print $fh $TRS;
+      }
+
+      {
+         while (my ($k, $v) = each %FACEINFO) {
+            length $v->{data32} or warn "$k: face has no png32. this will not work (shoddy gcfclient will crash of course).\n";
+            length $v->{data64} or warn "$k: face has no png64. this will not work very well.\n";
+
+            length $v->{data32} <= 10000 or warn "$k: face32 larger than 10000 bytes, will not work with crossfire client.\n";
+            #length $v->{data64} <= 10000 or warn "$k: face64 larger than 10000 bytes.\n";
+
+            $v->{chksum32} = Digest::MD5::md5 $v->{data32};
+            $v->{chksum64} = Digest::MD5::md5 $v->{data64};
+         }
+
+         open my $fh, ">:perlio", "$DATADIR/facedata~"
+            or die "$DATADIR/facedata~: $!";
+
+         print $fh freeze {
+            version => 2,
+            faceinfo => \%FACEINFO,
+            animinfo => \%ANIMINFO,
+         };
+      }
+
+      for (qw(archetypes facedata treasures)) {
+         chmod 0644, "$DATADIR/$_~";
+         rename "$DATADIR/$_~", "$DATADIR/$_"
+            or die "$DATADIR/$_: $!";
+      }
+
+      print "archetype data installed successfully.\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,