#!/usr/bin/perl
# $Id$
# compress man and info pages.

use strict;
use warnings;
use Cwd;
use File::Find;
use File::Basename;

my $ext = $ARGV[0] ||= '.gz';
die "Unknown extension $ext" unless $ext =~ /^\.(?:gz|bz2|lzma)$/;

my $buildroot = $ENV{RPM_BUILD_ROOT};
die "No build root defined" unless $buildroot;
die "Invalid build root" unless -d $buildroot;
chdir($buildroot) or die "Can't cd to $buildroot: $!";

my $exclude_pattern = join('|',
    map { '(:?' . quotemeta($_) . ')' }
    $ENV{EXCLUDE_FROM_COMPRESS} ?
        split(' ', $ENV{EXCLUDE_FROM_COMPRESS}) : ()
);
$exclude_pattern = qr/$exclude_pattern/;

my @sodirs = qw{
    usr/man
    usr/X11R6/man
    usr/lib/perl5/man
};
my @mandirs = qw{
    usr/info
    usr/share/info
    usr/man
    usr/share/man
    usr/X11/man
    usr/lib/perl5/man
};

# Now the .so conversion.
my (@sofiles, @sodests);
foreach my $dir (@sodirs) {
    find(\&find_so_man, $dir) if -e $dir;
}
foreach my $sofile (@sofiles) {
    my $sodest = shift(@sodests);
    system "rm", "-f",$sofile;
    system "ln", "-sf",$sodest,$sofile;
}

my @files;
foreach my $dir (@mandirs) {
    find(\&find_uncompressed_man, $dir) if -e $dir;
}

if ($ext ne '.gz') {
    my @gz_files;
    my $gz_function = get_find_compressed_man_function(\@gz_files, 'gz');
    foreach my $dir (@mandirs) {
        find($gz_function, $dir) if -e $dir;
    }
    if (@gz_files) {
        xargs(\@gz_files, "gzip", "-d");
        die "Something wrong with the decompression of the gzip man/info file"
            if $?;
        push(@files, map { substr($_, 0, -3) } @gz_files);
    }
}
if ($ext ne '.bz2') {
    my @bz_files;
    my $bz_function = get_find_compressed_man_function(\@bz_files, 'bz2');
    foreach my $dir (@mandirs) {
        find($bz_function, $dir) if -e $dir;
    }
    if (@bz_files) {
        xargs(\@bz_files, "bzip2", "-d");
        die "Something wrong with the decompression of the bzip2 man/info file"
            if $?;
        push(@files, map { substr($_, 0, -4) } @bz_files);
    }
}
if ($ext ne '.lzma') {
    my @lzma_files;
    my $lzma_function = get_find_compressed_man_function(\@lzma_files, 'lzma');
    foreach my $dir (@mandirs) {
        find($lzma_function, $dir) if -e $dir;
    }
    if (@lzma_files) { 
        xargs(\@lzma_files, "lzmash", "-d");
        die "Something wrong with the decompression of the lzma man/info file"
            if $?;
        push(@files, map { substr($_, 0, -5) } @lzma_files);
    }
}

# Look for files with hard links. If we are going to compress both,
# we can preserve the hard link across the compression and save
# space in the end.
my @f;
my (%hardlinks, %seen);
foreach (@files) {
    my ($dev, $inode, undef, $nlink) = stat($_);
    if ($nlink > 1) {
        if (! $seen{"$inode.$dev"}) {
            $seen{"$inode.$dev"} = $_;
            push @f, $_;
        } else {
            # This is a hardlink.
            $hardlinks{$_} = $seen{"$inode.$dev"};
        }
    } else {
        push @f, $_;
    }
}

if (@f) {
    # Make executables not be anymore.
    xargs(\@f, "chmod", "a-x");

    my @command = $ext eq '.gz'   ? qw/gzip -9f/
                : $ext eq '.bz2'  ? qw/bzip2 -9f/
                : $ext eq '.lzma' ? qw/lzma -9f --text/
                :                   qw//
                ;
    xargs(\@f, @command);
}


# Now change over any files we can that used to be hard links so
# they are again.
foreach (keys %hardlinks) {
    # Remove old file.
    system("rm", "-f", $_);
    # Make new hardlink.
    system("ln", "$hardlinks{$_}$ext", "$_$ext");
}

# Fix up symlinks that were pointing to the uncompressed files.
my $FIND;
open($FIND, "find $buildroot -type l |");
while (<$FIND>) {
    local $_ = $_;
    chomp;
    my ($directory) = m!(.*)/!;
    my $linkval = readlink($_);
    if (! -e "$directory/$linkval" && -e "$directory/$linkval$ext") {
        system("rm", "-f", $_);
        system("ln", "-sf", "$linkval$ext", "$_$ext");
    } elsif (! -e "$directory/$linkval" && ! -e "$directory/$linkval$ext" && $directory =~ m|man/|)  {
        #Bad link go on nowhere (any better idea) ?
        unlink($_);
    }

}

# Run a command that may have a huge number of arguments, like xargs does.
# Pass in a reference to an array containing the arguments, and then other
# parameters that are the command and any parameters that should be passed to
# it each time.
sub xargs {
    my $args = shift;

    # The kernel can accept command lines up to 20k worth of characters.
    my $command_max = 20000;

    # Figure out length of static portion of command.
    my $static_length = 0;
    foreach (@_) {
        $static_length += length($_)+1;
    }

    my @collect;
    my $length = $static_length;
    foreach (@$args) {
        if (length($_) + 1 + $static_length > $command_max) {
            error(qq(This command is greater than the maximum command size allowed by the kernel, and cannot be split up further. What on earth are you doing? "@_ $_"));
        }
        $length+=length($_) + 1;
        if ($length < $command_max) {
            push @collect, $_;
        } else {
            system(@_,@collect) if $#collect > -1;
            @collect = $_;
            $length = $static_length + length($_) + 1;
        }
    }
    system(@_,@collect) if $#collect > -1;
}

# Check if a file is a .so man page, for use by File::Find.
sub find_so_man() {
    # skip symlinks
    return if -l $_;
    # skip directories
    return if -d $_;
    # The -s test is becuase a .so file tends to be small. We don't want
    # to open every man page. 1024 is arbitrary.
    return if -s $_ > 1024;
    # skip excluded files
    return if $File::Find::name =~ $exclude_pattern;

    # Test first line of file for the .so thing.
    my $SOTEST;
    open($SOTEST, $_);
    my $l = <$SOTEST>;
    close $SOTEST;
    if ($l =~ m/\.so\s+(.*)/) {
        my $solink=$1;
        # This test is here to prevent links like ... man8/../man8/foo.8
        if (basename($File::Find::dir) eq dirname($solink)) {
            $solink = basename($solink);
        } else {
            $solink = "../$solink";
        }

        push @sofiles, $File::Find::name;
        push @sodests, $solink;
    }
}

sub find_uncompressed_man {
    # skip symlinks
    return if -l $_;
    # skip directories
    return if -d $_;
    # skip excluded files
    return if $File::Find::name =~ $exclude_pattern;
    # skip compressed files
    return if $_ =~ /\.(?:gz|bz2|lzma)$/;
    # skip particular files
    return if $_ eq 'dir' || $_ eq 'whatis';

    push @files, $File::Find::name;
}

sub get_find_compressed_man_function {
    my ($array, $extension) = @_;

    my $function = sub {
        # skip symlinks
        return if -l $_;
        # skip directories
        return if -d $_;
        # skip excluded files
        return if $File::Find::name =~ $exclude_pattern;
        # skip everything but files with wanted extension
        return if $_ !~ /\.$extension$/;

        push @$array, $File::Find::name;
    };

    return $function;
}