#!/usr/bin/perl -w
#
# $Id: rpmbuildupdate.in 59822 2006-09-04 14:10:30Z guillomovitch $

use strict;
use AppConfig qw/:argcount/;
use Cwd;
use DateTime;
use File::Basename;
use File::Copy; 
use File::Spec;
use File::Path;
use File::Fetch;
use List::MoreUtils qw/all/;
use Pod::Usage;
use RPM4;
use String::ShellQuote;

# silence File::Fetch warnings
$File::Fetch::WARN = 0;
# blacklist lynx handler for false positives
$File::Fetch::BLACKLIST = [ qw/ftp lynx/ ];

# add jabberstudio, collabnet, http://www.sourcefubar.net/, http://sarovar.org/
# http://jabberstudio.org/files/ejogger/
# http://jabberstudio.org/projects/ejogger/project/view.php     
my @SITES = (
    {
        from => 'http://(.*)\.(?:sourceforge|sf)\.net/?(.*)',
        to   => 'http://prdownloads.sourceforge.net/$1/$2'
    },
    { # to test
        from => 'https?://gna.org/projects/([^/]*)/(.*)',
        to   => 'http://download.gna.org/$1/$2'
    },
    {
        from => 'http://(.*)\.berlios.de/(.*)',
        to   => 'http://download.berlios.de/$1/$2'
    },
    { # to test , and to merge with regular savanah ?
        from => 'https?://savannah.nongnu.org/projects/([^/]*)/(.*)',
        to   => 'http://savannah.nongnu.org/download/$1/$2'
    },
    { # to test
        from => 'https?://savannah.gnu.org/projects/([^/]*)/(.*)',
        to   => 'http://savannah.gnu.org/download/$1/$2'
    },
    {
        from => 'http://search.cpan.org/dist/([^-]+)-.*',
        to   => 'http://www.cpan.org/modules/by-module/$1/'
    }
);

my @SF_MIRRORS = qw/
    ovh
    mesh
    switch
    belnet
    puzzle
    heanet
    kent
    voxel
    easynews
    cogent
    optusnet
    jaist
    nchc
    citkit
/;

my @EXTENSIONS = qw/
    .tar.gz
    .tgz
    .tar.Z
    .zip
/;

my $config = AppConfig->new(
    {
        CASE => 1,
        ERROR => \&pod2usage,
        GLOBAL => {
            DEFAULT  => '',
            ARGCOUNT => ARGCOUNT_ONE,
        }
    },
    srpms => {
        DEFAULT  => '',
        VALIDATE => sub { return all { -d } split(/,/, $_[1]) },
        ARGCOUNT => ARGCOUNT_ONE
    },
    rpmoption => {
        DEFAULT  => '',
        ARGCOUNT => ARGCOUNT_ONE
    },
    top => {
        DEFAULT  => '',
        ARGCOUNT => ARGCOUNT_ONE
    },
    changelog => {
        DEFAULT  => '',
        ARGCOUNT => ARGCOUNT_LIST
    },
    release => {
        DEFAULT  => '',
        ARGCOUNT => ARGCOUNT_ONE
    },
    releasesuffix => {
        DEFAULT  => '',
        ARGCOUNT => ARGCOUNT_ONE
    },
    nosource => {
        DEFAULT  => 0,
        ARGCOUNT => ARGCOUNT_NONE
    },
    noupdate => {
        DEFAULT  => 0,
        ARGCOUNT => ARGCOUNT_NONE
    },
    nobuild => {
        DEFAULT  => 0,
        ARGCOUNT => ARGCOUNT_NONE
    },
    nodownload => {
        DEFAULT  => 0,
        ARGCOUNT => ARGCOUNT_NONE
    },
    execute => {
        DEFAULT  => '',
        ARGCOUNT => ARGCOUNT_ONE
    },
    execafterbuild => {
        DEFAULT  => '',
        ARGCOUNT => ARGCOUNT_ONE
    },
    installbuildrequires => {
        DEFAULT  => '',
        ARGCOUNT => ARGCOUNT_ONE
    },
    srpmonly => {
        DEFAULT => '',
        ARGCOUNT => ARGCOUNT_NONE
    },
);


foreach my $f ('/etc/rpmbuildupdate.conf', "$ENV{HOME}/.rpmbuildupdaterc") {    
    $config->file($f) if -f $f;
}       
$config->args();

# global variables
my $topdir = $config->get('top') || RPM4::expand('%_topdir');
RPM4::add_macro("_topdir $topdir");
my $sourcedir = RPM4::expand('%_sourcedir');

my ($name, $version, $result);
if ($ARGV[0]) {
    $name    = $ARGV[0];
    $version = $ARGV[1];
    if (-f $name) {
        if ($name =~ /.spec$/) {
            $result = build_from_spec($name, $version);
        } elsif ($name =~ /.(?:no)?src.rpm$/) {
            $result = build_from_src($name, $version);
        } else {
            pod2usage(-exitval => 255);
        }
    } else {
        $result = build_from_repository($name, $version)
    }
} else {
    pod2usage(-exitval => 255);
}

exit $result ? 0 : 1;

sub system_die {
    my ($command, $message) = @_;
    $message ||= "$command failed";
    # do not forget , return value of 1 means failure in unix
    if (system($command)) {
        $! = 4;
        die $message;
    }
}

sub fetch {
    my ($url) = @_;
    # if you add a handler here, do not forget to add it to the body of build()
    return fetch_tarball($url) if $url =~ m!^(ftp|https?)://!;
    return fetch_svn($url) if $url =~ m!^svns?://!; 
}

sub fetch_svn {
    my ($url) = @_;
    my ($basename, $repos);

    $basename = basename($url);
    ($repos = $url) =~ s|/$basename$||;
    $repos =~ s/^svn/http/;
    die "Cannot extract revision number from the name." if $basename !~ /^(.*)-([^-]*rev)(\d\d*).tar.bz2$/;
    my ($name, $prefix, $release) = ($1, $2, $3);
    my $dir="$ENV{TMP}/rpmbuildupdate-$$"; 
    my $current_dir = cwd();
    mkdir $dir or die "Cannot create dir $dir";
    chdir $dir or die "Cannot change dir to $dir";
    system_die("svn co -r $release $repos", "svn checkout failed on $repos");
    my $basedir = basename($repos);

    # FIXME quite inelegant, should use a dedicated cpan module.
    my $complete_name = "$name-$prefix$release";
    move($basedir, $complete_name);
    system_die("find $complete_name -name '.svn' | xargs rm -Rf");
    system_die("tar -cjf $complete_name.tar.bz2 $complete_name", "tar failed");
    system_die("mv -f $complete_name.tar.bz2 $current_dir");
    chdir $current_dir;
}

sub fetch_tarball {
    my ($url) = @_;

    print "attempting to download $url\n";
    my $ff = File::Fetch->new(uri => $url);
    my $result = $ff->fetch(to => $sourcedir);
    if ($result) {
        return 1;
    } else {
        my $filename = basename($url);
        foreach my $extension (@EXTENSIONS) {
            my $alternate_url = $url;
            my $alternate_filename = $filename;
            $alternate_url =~ s/\.tar\.bz2/$extension/;
            $alternate_filename =~ s/\.tar\.bz2/$extension/;
            print "attempting to download $alternate_url\n";
            $ff = File::Fetch->new(uri => $alternate_url);
            $result = $ff->fetch(to => $sourcedir);

            if ($result) {
                system_die("bzme -f -F $sourcedir/$alternate_filename");
                return 1;
            }
        }
    }

    # failure
    return;
}

sub build_from_repository {
    my ($name, $newversion) = @_;
    my $src_file;

    foreach my $srpm_dir (split(/,/, $config->get('srpms'))) {
        $src_file = find_source_package($srpm_dir, $name);
        last if $src_file;
    }   

    die "No source available for package $name, aborting" unless $src_file;

    return build_from_src($src_file, $newversion);
}

sub build_from_src {
    my ($src_file, $newversion) = @_;

    my ($spec_file) = RPM4::installsrpm($src_file);

    die "Unable to install source package $src_file, aborting"
        unless $spec_file;

    return build_from_spec($spec_file, $newversion);
}

sub get_packager {
    my $packager = RPM4::expand('%packager');
    if ($packager eq '%packager') {
        my ($login, $gecos) = (getpwuid($<))[0,6];
        $packager = $ENV{EMAIL} ?
            "$login <$ENV{EMAIL}>" :
            "$login <$login\@mandriva.com>";
    }
    return $packager;
}

sub build_from_spec {
    my ($spec_file, $newversion) = @_;

    my $pkg_spec = RPM4::Spec->new($spec_file, force => 1)
        or die "Unable to parse spec $spec_file\n"; 
    my $pkg_header = $pkg_spec->srcheader();

    my $name    = $pkg_header->tag('name');
    my $version = $pkg_header->tag('version');
    my $release = $pkg_header->tag('release');

    # handle everything dependant on new version/release
    if ($newversion) {
        print "===> Building $name $newversion\n";
    } else {    
        print "===> Rebuilding $name\n";
    }

    # install buildrequires
    if ($config->get('installbuildrequires')) {
        my @requires = $pkg_header->tag('requires');
        if (@requires) {
            print "===> Installing BuildRequires : @requires\n";
            system($config->get('installbuildrequires') . ' ' . shell_quote @requires);
        }
    };

    # compute sources URL
    my @sources = $pkg_spec->sources_url();

    my @remote_sources = 
        grep { /(?:ftp|svns?|https?):\/\/\S+/ } @sources;

    if (! @remote_sources) {
        print "No remote sources were found, fall back on URL tag ...\n";

        my $url = $pkg_header->tag('url');

        foreach my $site (@SITES) {
            # curiously, we need two level of quoting-evaluation here :(
            if ($url =~ s!$site->{from}!qq(qq($site->{to}))!ee) {
                last;
            }    
        }

        push(@remote_sources, "$url/$sources[0]")
    }

    # download sources
    if (
        $newversion     &&           # new version
        @remote_sources &&           # remote sources
        ! $config->get('nodownload')
    ) { 
        my $found = 0;

        foreach my $remote_source (@remote_sources) {
            $remote_source =~ s/$version/$newversion/g;

            my $basename = basename($remote_source);
            rmtree("$sourcedir/$basename");

            # GNOME: add the major version to the URL automatically
            # for example: ftp://ftp://ftp.gnome.org/pub/GNOME/sources/ORbit2/ORbit2-2.10.0.tar.bz2
            # is rewritten in ftp://ftp.gnome.org/pub/GNOME/sources/ORbit2/2.10/ORbit2-2.10.0.tar.bz2
            if ($remote_source =~ m!ftp.gnome.org/pub/GNOME/sources/!) {
                (my $major = $newversion) =~ s/([^.]+\.[^.]+).*/$1/;
                $remote_source =~ s!(.*/)(.*)!$1$major/$2!;
            }

            if ($remote_source =~ m!http://prdownloads.sourceforge.net!) {
                # download from sourceforge mirrors
                foreach my $sf_mirror (@SF_MIRRORS) {
                    my $sf_remote_source = $remote_source;
                    $sf_remote_source =~ s!prdownloads.sourceforge.net!$sf_mirror.dl.sourceforge.net/sourceforge!;
                    $found = fetch_tarball($sf_remote_source);
                    last if $found;
                }
            } else {
                # download directly
                $found = fetch($remote_source);
            }

            unless ($found) {
                $! = 2;
                die "Unable to download source: $remote_source";
            }
        }

    }

    # update spec file
    unless ($config->get('noupdate')) {
        open(my $in, '<', $spec_file)
            or die "Unable to open file $spec_file: $!";

        my $spec;
        my $newrelease = '';
        my $header = '';
        while (my $line = <$in>) {
            if ($newversion             && # version change needed
                $version ne $newversion && # not already done
                $line =~ /^
                    (
                        \%define\s+version\s+ # defined as macro
                    |
                        (?i)Version:\s+       # defined as tag
                    )
                    (.*)                      # value
                $/ox
            ) {
                my ($directive, $definition) = ($1, $2);
                $line = $directive . $newversion . "\n";

                # just to skip test for next lines
                $version = $newversion;
            }

            if ($release ne $newrelease && # not already done
                $line =~ /^
                (
                    \%define\s+release\s+ # defined as macro
                |
                    (?i)Release:\s+       # defined as tag
                )
                (.*)                      # definition
                $/ox
            ) {
                my ($directive, $definition) = ($1, $2);

                $newrelease = $config->get('release');
                if (! $newrelease) {
                    # if not explicit release given, try to compute it
                    my ($macro, $value) = $definition =~ /^(%\w+\s+)?(.*)$/;

                    die "Unable to extract release value from definition $definition"
                        unless $value;

                    my ($prefix, $number, $suffix); 
                    if ($newversion) {
                        $number = 1;
                    } else {
                        # optional suffix from configuration
                        my $dist_suffix = $config->get('releasesuffix');

                        ($prefix, $number, $suffix) =
                            $value =~ /^(.*)(\d+)(\Q$dist_suffix\E)?$/;

                        die "Unable to extract release number from value $value"
                            unless $number;

                        $number++;
                    }

                    $newrelease = 
                        ($macro ? $macro : "") .
                        ($prefix ? $prefix : "") .
                        $number .
                        ($suffix ? $suffix : "");

                }

                $line = $directive . $newrelease . "\n";

                # just to skip test for next lines
                $release = $newrelease;
            }

            # help to have shorter unilines
            $_ = $line;
            eval $config->get('execute') if $config->get('execute');

            $spec .= $line;

            if (!$header &&              # not already done
                $line =~ /^\%changelog/
            ) {
                # skip until first changelog entry, as requested for bug #21389
                while ($line = <$in>) {
                    last if $line =~ /^\*/;
                    $spec .= $line;
                }

                my @entries = @{$config->get('changelog')};
                if (@entries) {
                    s/\%\%VERSION/$newversion/ foreach @entries;
                } else  {
                    @entries = $newversion ?
                        "New version $newversion" :
                        'Rebuild';
                }

                $header = RPM4::expand(
                    DateTime->now()->strftime('%a %b %d %Y') . ' ' .
                    get_packager() . ' ' .
                    (
                        $pkg_header->hastag('epoch') ?
                            $pkg_header->tag('epoch') . ':' :
                            ''
                    ) .
                    $version . '-' .
                    $release
                );

                $spec .= "* $header\n";
                foreach my $entry (@entries) {
                    $spec .= "- $entry\n";
                }
                $spec .= "\n";

                # don't forget kept line
                $spec .= $line;
            }
        }
        close($in);

        open(my $out, '>', $spec_file)
            or die "Unable to open file $spec_file: $!";
        print $out $spec;
        close($out);
    }

    unless ($config->get('nobuild')) {
        my $rpm = qq(rpm --define  "_topdir $topdir");
        my $options = $config->get('rpmoption');

        if ($config->get('srpmonly')) {
            $result =
                 system("$rpm -bs $options --nodeps $spec_file");
        } else {
            $result =
                system("$rpm -ba $options $spec_file");
        }

        # normalize return value to 1 for failures
        $result = $result ? 1 : 0;
    }

    if ($config->get('execafterbuild')) {
        my @rpms_upload;
        push(@rpms_upload, $pkg_spec->srcrpm);
        foreach my $pkg_bin_file ($pkg_spec->binrpm()) {
            -f $pkg_bin_file or next;
            push(@rpms_upload, $pkg_bin_file);
        }
        system("$config->get('execafterbuild') " . shell_quote @rpms_upload);
    }

    return $result;
}

sub find_source_package {
    my ($dir, $name) = @_;

    my $file;
    opendir(my $DIR, $dir) or die "Unable to open $dir: $!";
    while (my $entry = readdir($DIR)) {
        if ($entry =~ /^\Q$name\E-[^-]+-[^-]+\.src.rpm$/) {
            $file = "$dir/$entry";
            last;
        }
    }
    closedir($DIR);
    return $file;
}

__END__

=head1 NAME

rpmbuildupate - automatic package rebuilder

=head1 SYNOPSIS

rpmbuildupdate [options] <package> <version>

rpmbuildupdate [options] <file.spec> <version>

rpmbuildupdate [options] <file.src.rpm> <version>

Options:

    --srpms <path>                      specify SRPMS path
    --rpmoption <option>                pass this option to rpm during build
    --release <release>                 release tag
    --releasesuffix <suffix>            release tag suffix
    --changelog <message>               use a alternate message
    --top <dir>                         specify rpm top dir
    --nosource                          do not install source
    --noupdate                          do not modify the spec file
    --nodownload                        do not download any files
    --nobuild                           do not build the package
    --execute <command>                 execute a command during the build
    --execafterbuild <command>          execute a command after the build,
    --installbuildrequires <command>    command used to install build requires

=head1 OPTIONS

=over

=item B<--srpms>

Specify SRPMS path, separate folder with a comma.

=item B<--rpmoption>

Pass this option to rpm during build.

=item B<--release>

Complete release tag value.

=item B<--releasesuffix>

Release tag value suffix, remaining should be computed automatically.

=item B<--changelog>

Changelog entry message. Several can be used, and they will be automatically
formatted, with \%\%VERSION substituted by version. Defaults to 'New version
\%\%VERSION' when a new version is given, and 'Rebuild' otherwise.

=item B<--top>

Specify rpm tree top directory. Defaults to rpm configuration.

=item B<--nosource>

Do not install source from (urpmi x.src.rpm).

=item B<--noupdate>

do not modify the spec file

=item B<--nodownload>

Do not download any files.

=item B<--nobuild>

Do not build the package.

=item B<--execute>

Execute a perl command for each line of the spec file. $_ will hold the value of the line. 

=item B<--execafterbuild>

Execute a shell command after the build, with files created as arguments.

=item B<--installbuildrequires>

Command to be used to install build dependencies.

=item B<--srpmonly>

Only build a srpm in the building phas

=back

=cut

=head1 DESCRIPTION

This tool automatises rpm package building. When given an explicit new version,
it downloads new sources automatically, updates the spec file and builds
a new version. When not given a new version, it just updates the spec file a
builds a new release.

Warning, not every spec file syntax is supported. If you use specific syntax,
you'll have to ressort to imperative switches such as B<--execute> to handle
update correctly.

Here is version update algorithm (only used when building a new version):

=over

=item * find the first definition of version

=item * replace it with new value

=back

Here is release update algorithm:


=over

=item * find the first definition of release

=item * if explicit value given with B<--release>:

=over

=item * replace value

=back

=item * otherwise:

=over

=item * extract any macro occuring in the leftmost part (such as %mkrel)

=item * extract any occurence of B<--releasetag> value in the rightmost part

=item * if a new version is given:

=over

=item * replace with 1

=back

=item * otherwise:

=over

=item * increment by 1

=back

=back

=back

In both cases, both direct definition:

    Version:    X

or indirect definition:

    %define version X
    Version:    %{version}

are supported. Any more complex one is not.

=head1 RETURN CODES

=over

=item B<255>

usage 

=item B<6>

cannot open the spec file

=item B<5>

Random problem

=item B<4> 

A external command failed

=item B<2>

Invalid url

=item B<1>

Only src is build

=item B<0>

No error

=back

=head1 AUTHORS

Julien Danjou <danjou@mandriva.com>

Michael Scherer <misc@mandriva.org>

Guillaume Rousse <guillomovitch@mandriva.org>

=head1 COPYRIGHT AND LICENSE

Copyright (c) 2003-2005 Mandriva.

Permission to use, copy, modify, and distribute this software and its
documentation under the terms of the GNU General Public License is hereby 
granted. No representations are made about the suitability of this software 
for any purpose. It is provided "as is" without express or implied warranty.
See the GNU General Public License for more details.
