--- deliantra/server/utils/cfutil.in 2007/03/06 22:07:56 1.1 +++ deliantra/server/utils/cfutil.in 2007/04/01 00:36:35 1.19 @@ -1,3 +1,446 @@ #!@PERL@ -@CONVERT@ +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 (); +use Digest::MD5; +use Storable; $Storable::canonical = 1; + +sub usage { + warn <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"; + + 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" + and die "map installation failed.\n"; + + print "maps installed successfully.\n"; +} + +{ + our %FACEINFO; + our @ARC; + our $TRS; + our $NFILE; + our %ANIM; + + our $QUANTIZE = "+dither -colorspace RGB -colors 256"; + + our (@png, @trs, @arc); # files we are interested in + + sub commit_png($$$) { + my ($name, $data, $T) = @_; + + $FACEINFO{$name}{"data$T"} = $data; + } + + sub process_png { + while (@png) { + my ($path, $delete) = @{pop @png}; + + my $png; + aio_lstat $path; + my ($size, $mtime) = (stat _)[7,9]; + + if (0 > aio_load $path, $png) { + warn "$path: $!, skipping.\n"; + next; + } + + 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; + } + + if ($w % $T || $h % $T) { + warn "$path: weird png size ($w $h), skipping.\n"; + next; + } + + 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)) { + warn "rescale $other\n";#d# + 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; + }; + } + + push @png, [$other, !$CACHE]; + } + + # 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) && $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:-", + (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]; + } + }; + } + + 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; + } + + aio_unlink $path if $delete; + } + } + + 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; + + $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$/; + + 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) { + $o->{animation} = "$o->{_name}"; + + for (@$anim) { + $_ .= $ext unless /^facings\s|^blank.x11$|^empty.x11$/; + } + + $ANIM{"$o->{_name}$ext"} = + join "", map "$_\n", + "anim $o->{_name}", + @$anim, + "mina"; + } + + 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 ($face, $smooth) = split /\s+/, $smooth; + # skip empty_S.x11, it seems to server no purpose whatsoever + # but increases bandwidth demands and worse. + unless ($smooth eq "empty_S.x11") { + $FACEINFO{$face}{smooth} = $smooth; + } + } + } + } + } + } + + 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 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", 0]; + } 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", + "(this can take a long time if you run this\n", + "for the first time or do not use --cache).\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 ( + # 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), + ); + + { + open my $fh, ">:utf8", "$DATADIR/animations~" + or die "$DATADIR/animations~: $!"; + print $fh join "", map $ANIM{$_}, sort keys %ANIM + } + + { + open my $fh, ">:utf8", "$DATADIR/archetypes~" + or die "$DATADIR/archetypes~: $!"; + substr $_->{editor_folder}, 0, 1 + length $path, "" for @ARC; + print $fh Crossfire::archlist_to_string \@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"; + + $v->{chksum32} = Digest::MD5::md5 $v->{data32}; + $v->{chksum64} = Digest::MD5::md5 $v->{data64}; + } + + open my $fh, ">:perlio", "$DATADIR/facedata~" + or die "$DATADIR/facedata~: $!"; + + $FACEINFO{""} = { version => 1}; + print $fh Storable::nfreeze \%FACEINFO; + } + + for (qw(archetypes facedata animations 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, + "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; +