Youri::Package::RPM::Updater - Update RPM packages

    my $updater = Youri::Package::RPM::Updater->new();
    $updater->update_from_source('foo-1.0-1.src.rpm', '2.0');
    $updater->update_from_spec('foo.spec', '2.0');
    $updater->update_from_repository('foo', '2.0');

    Version:    X

    %define version X
    Version:    %{version}

# $Id: Updater.pm 2301 2011-01-22 12:10:08Z guillomovitch $

package Youri::Package::RPM::Updater;

use strict;
use Cwd;
use Carp;
use DateTime;
use File::Basename;
use File::Copy; 
use File::Spec;
use File::Path;
use File::Temp qw/tempdir/;
use List::MoreUtils qw/none/;
use LWP::UserAgent;
use SVN::Client;
use Readonly;
use YAML::AppConfig;
use Youri::Package::RPM 0.002;
use version; our $VERSION = qv('0.6.0');
use feature qw/switch/;

# default values
Readonly::Scalar my $defaults => <<'EOF';
---
srpm_dirs:

timeout: 10

agent: youri-package-updater/VERSION

url_rewrite_rules:
    - 
        from: http://(.*)\.(?:sourceforge|sf)\.net/?(.*)
        to:   http://prdownloads.sourceforge.net/$1/$2
    -
        from: https?://gna.org/projects/([^/]*)/(.*)'
        to:   http://download.gna.org/$1/$2
    -
        from: http://(.*)\.berlios.de/(.*)
        to:   http://download.berlios.de/$1/$2
    -
        from: https?://savannah.nongnu.org/projects/([^/]*)/(.*)
        to:   http://savannah.nongnu.org/download/$1/$2
    -
        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/

archive_content_types:
    tar: 
        - application/x-tar
    gz:
        - application/x-tar
        - application/x-gz
        - application/x-gzip
    tgz:
        - application/x-tar
        - application/x-gz
        - application/x-gzip
    bz2:
        - application/x-tar
        - application/x-bz2
        - application/x-bzip
        - application/x-bzip2
    tbz2:
        - application/x-tar
        - application/x-bz2
        - application/x-bzip
        - application/x-bzip2
    zip:
        - application/x-gzip
    lzma:
        - application/x-tar
        - application/x-lzma
    _all:
        - application/x-download
        - application/octet-stream
        - application/empty

alternate_extensions:
    - tar.gz
    - tgz
    - zip

sourceforge_mirrors:
    - ovh
    - mesh
    - switch

new_version_message: New version %%VERSION

new_release_message: Rebuild
EOF

my $wrapper_class = Youri::Package::RPM->get_wrapper_class();

sub new {
    my ($class, %options) = @_;

    # force internal rpmlib configuration
    my ($topdir, $sourcedir);
    if ($options{topdir}) {
        $topdir = File::Spec->rel2abs($options{topdir});
        $wrapper_class->add_macro("_topdir $topdir");
    } else {
        $topdir = $wrapper_class->expand_macro('%_topdir');
    }
    if ($options{sourcedir}) {
        $sourcedir = File::Spec->rel2abs($options{sourcedir});
        $wrapper_class->add_macro("_sourcedir $sourcedir");
    } else {
        $sourcedir = $wrapper_class->expand_macro('%_sourcedir');
    }

    my $config = YAML::AppConfig->new(string => $defaults);
    $config->merge(file => '/etc/youri/updater.conf')
        if -r '/etc/youri/updater.conf';
    $config->merge(file => "$ENV{HOME}/.youri/updater.conf")
        if -r "$ENV{HOME}/.youri/updater.conf";
     
    my $self = bless {
        _topdir               => $topdir,
        _sourcedir            => $sourcedir,
        _verbose              => $options{verbose}           // 0,
        _check_new_version    => $options{check_new_version} // 1,
        _release_suffix       => $options{release_suffix}    //  undef,
        _timeout              => $options{timeout} //
                                 $config->get('timeout'),
        _agent                => $options{agent} //
                                 $config->get('agent'),
        _srpm_dirs            => $options{srpm_dirs} //
                                 $config->get('srpm_dirs'),
        _alternate_extensions => $options{alternate_extensions} //
                                 $config->get('alternate_extensions'),
        _sourceforge_mirrors  => $options{sourceforge_mirrors} //
                                 $config->get('sourceforge_mirrors'),
        _new_version_message  => $options{new_version_message} //
                                 $config->get('new_version_message'),
        _new_release_message  => $options{new_release_message} //
                                 $config->get('new_release_message'),
        _url_rewrite_rules    => $options{url_rewrite_rules} //
                                 $config->get('url_rewrite_rules'),
        _archive_content_types => $options{archive_content_types} //
                                  $config->get('archive_content_types'),
    }, $class;

    $self->{_agent} =~ s/VERSION/$VERSION/;

    return $self;
}

sub update_from_repository {
    my ($self, $name, $new_version, %options) = @_;
    croak "Not a class method" unless ref $self;
    my $src_file;

    if ($self->{_srpm_dirs}) {
        foreach my $srpm_dir (@{$self->{_srpm_dirs}}) {
            $src_file = $self->_find_source_package($srpm_dir, $name);
            last if $src_file;
        }   
    }

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

    $self->update_from_source($src_file, $new_version, %options);
}

sub update_from_source {
    my ($self, $src_file, $new_version, %options) = @_;
    croak "Not a class method" unless ref $self;

    $wrapper_class->set_verbosity(0);
    my ($spec_file) = $wrapper_class->install_srpm($src_file);

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

    $self->update_from_spec($spec_file, $new_version, %options);
}

sub update_from_spec {
    my ($self, $spec_file, $new_version, %options) = @_;
    croak "Not a class method" unless ref $self;

    $options{download}         = 1 unless defined $options{download};
    $options{update_revision}  = 1 unless defined $options{update_revision};
    $options{update_changelog} = 1 unless defined $options{update_changelog};

    my $spec = $wrapper_class->new_spec($spec_file, force => 1)
        or croak "Unable to parse spec $spec_file\n"; 

    $self->_update_spec($spec_file, $spec, $new_version, %options) if
        $options{update_revision}      ||
        $options{update_changelog}     ||
        $options{spec_line_callback}   ||
        $options{spec_line_expression};

    $spec = $wrapper_class->new_spec($spec_file, force => 1)
        or croak "Unable to parse updated spec file $spec_file\n"; 

    $self->_download_sources($spec, $new_version, %options) if
        $new_version       &&
        $options{download};
}

sub _update_spec {
    my ($self, $spec_file, $spec, $new_version, %options) = @_;

    my $header = $spec->srcheader();

    # return if old version >= new version
    my $old_version = $header->tag('version');
    return if $options{check_new_version} &&
              $new_version                &&
              RPM4::rpmvercmp($old_version, $new_version) >= 0;

    my $new_release = $options{release} || '';
    my $epoch       = $header->tag('epoch');

    if ($options{spec_line_expression}) {
        $options{spec_line_callback} =
            _get_callback($options{spec_line_expression});
    }

    open(my $in, '<', $spec_file)
        or croak "Unable to open file $spec_file: $!";

    my $content;
    my ($version_updated, $release_updated, $changelog_updated);
    while (my $line = <$in>) {
        if ($options{update_revision} && # update required
            $new_version              && # version change needed
            !$version_updated            # not already done
        ) {
            my ($directive, $spacing, $value) =
                _get_new_version($line, $new_version);
            if ($directive && $value) {
                $line = $directive . $spacing . $value . "\n";
                $new_version = $value;
                $version_updated = 1;
            }
        }

        if ($options{update_revision} && # update required
            !$release_updated            # not already done
        ) {
            my ($directive, $spacing, $value) =
                _get_new_release($line, $new_version, $new_release, $self->{_release_suffix});
            if ($directive && $value) {
                $line = $directive . $spacing . $value . "\n";
                $new_release = $value;
                $release_updated = 1;
            }
        }

        # apply global and local callbacks if any
        $line = $options{spec_line_callback}->($line)
            if $options{spec_line_callback};

        $content .= $line;

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

            my @entries =
                $options{changelog_entries} ? @{$options{changelog_entries}} :
                $new_version                ? $self->{_new_version_message}  :
                                              $self->{_new_release_message}  ;
            foreach my $entry (@entries) {
                $entry =~ s/\%\%VERSION/$new_version/g;
            }

            my $title = $wrapper_class->expand_macro(
                DateTime->now()->strftime('%a %b %d %Y') .
                ' ' .
                $self->_get_packager() .
                ' ' .
                ($epoch ? $epoch . ':' : '') .
                ($new_version ? $new_version : $old_version) .
                '-' .
                $new_release
            );

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

            # don't forget kept line
            $content .= $line;

            # just to skip test for next lines
            $changelog_updated = 1;
        }
    }
    close($in);

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

sub _download_sources {
    my ($self, $spec, $new_version, %options) = @_;

    foreach my $source ($self->_get_sources($spec, $new_version)) {
        my $found;

        if ($source->{url} =~ m!http://prdownloads.sourceforge.net!) {
            # if content is hosted on source forge, attempt to download
            # from all configured mirrors
            foreach my $mirror (@{$self->{_sourceforge_mirrors}}) {
                my $sf_url = $source->{url};
                $sf_url =~ s!prdownloads.sourceforge.net!$mirror.dl.sourceforge.net/sourceforge!;
                $found = $self->_fetch_tarball($sf_url);
                last if $found;
            }
        } else {
            $found = $self->_fetch($source->{url});
        }

        croak "Unable to download source: $source->{url}" unless $found;

        # recompress source if neeeded
        _bzme($found) if $source->{bzme};
    }

}

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

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

    $basename = basename($url);
    ($repos = $url) =~ s|/$basename$||;
    $repos =~ s/^svn/http/;
    croak "Cannot extract revision number from the name."
        if $basename !~ /^(.*)-([^-]*rev)(\d\d*).tar.bz2$/;
    my ($name, $prefix, $release) = ($1, $2, $3);

    # extract repository in a temp directory
    my $dir = tempdir(CLEANUP => 1);
    my $archive = "$name-$prefix$release";
    my $svn = SVN::Client->new();
    $svn->export($repos, "$dir/$archive", $release);

    # archive and compress result
    my $result = system("tar -cjf $archive.tar.bz2 -C $dir $archive");
    croak("Error during archive creation: $?\n")
        unless $result == 0;
}

sub _fetch_tarball {
    my ($self, $url) = @_;

    my $agent = LWP::UserAgent->new();
    $agent->env_proxy();
    $agent->timeout($self->{_timeout});
    $agent->agent($self->{_agent});

    my $file = $self->_fetch_potential_tarball($agent, $url);

    # Mandriva policy implies to recompress sources, so if the one that was
    # just looked for was missing, check with other formats
    if (!$file and $url =~ /\.tar\.bz2$/) {
        foreach my $extension (@{$self->{_alternate_extensions}}) {
            my $alternate_url = $url;
            $alternate_url =~ s/\.tar\.bz2$/.$extension/;
            $file = $self->_fetch_potential_tarball($agent, $alternate_url);
            if ($file) {
                $file = _bzme($file);
                last;
            }
        }
    }

    return $file;
}

sub _fetch_potential_tarball {
    my ($self, $agent, $url) = @_;

    my $filename = basename($url);
    my $dest = "$self->{_sourcedir}/$filename";

    # don't attempt to download file if already present
    return $dest if -f $dest;

    print "attempting to download $url\n" if $self->{_verbose};
    my $response = $agent->mirror($url, $dest);
    if ($response->is_success()) {
        print "response: OK\n" if $self->{_verbose} > 1;
        my ($extension) = $filename =~ /\.(\w+)$/;
        if ($self->{_archive_content_types}->{$extension}) {
            # check content type for archives
            my $type = $response->header('Content-Type');
            print "checking content-type $type: " if $self->{_verbose} > 1;
            if (
                none { $type eq $_ }
                @{$self->{_archive_content_types}->{$extension}},
                @{$self->{_archive_content_types}->{_all}}
            ) {
                # wrong type
                print "NOK\n" if $self->{_verbose} > 1;
                unlink $dest;
                return;
            } else {
                print "OK\n" if $self->{_verbose} > 1;
            }
        }
        return $dest;
    } else {
        print "response: NOK\n" if $self->{_verbose} > 1;
        return;
    }
}


sub _get_packager {
    my ($self) = @_;
    my $packager = $wrapper_class->expand_macro('%packager');
    if ($packager eq '%packager') {
        my $login = (getpwuid($<))[0];
        $packager = $ENV{EMAIL} ? "$login <$ENV{EMAIL}>" : $login;
    }
    return $packager;
}


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

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

sub _get_sources {
    my ($self, $spec, $version) = @_;

    my $header = $spec->srcheader();
    my $name   = $header->tag('name');

    my @sources;

    # special cases: ignore sources defined in the spec file
    if ($name =~ /^perl-(\S+)/) {
        # source URL in the spec file can not be trusted, as it 
        # change for each release, so try to use CPAN metabase DB
        my $cpan_name = $1;
        $cpan_name =~ s/-/::/g;

        # ignore spec file URL, as it changes between releases
        my ($cpan_url, $cpan_version) = _get_cpan_package_info(
            $cpan_name
        );

        if ($cpan_url && $cpan_version && $cpan_version eq $version) {
            # use the result if available
            my $source = ($spec->sources_url())[0];
            @sources = ( { url => $cpan_url, bzme => $source =~ /\.tar\.bz2$/ } );
        }
    }

    return @sources if @sources;

    # default case: extract all sources defined with an URL in the spec file
    @sources =
        map { _fix_source($_, $version) }
        map { { url => $_, bzme => 0 } }
        grep { /(?:ftp|svns?|https?):\/\/\S+/ }
        $spec->sources_url();

    return @sources if @sources;

    # fallback case: try a single source, with URL deduced from package URL

    print "No remote sources were found, fall back on URL tag ...\n"
        if $self->{_verbose};

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

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

    my $source = ($spec->sources_url())[0];
    @sources = ( { url => $url . '/' . $source, bzme => 0 } );

    return @sources;
}

sub _get_callback {
    my ($expressions) = @_;

    my ($code, $sub);;
    $code .= '$sub = sub {';
    $code .= '$_ = $_[0];';
    foreach my $expression (
        ref $expressions eq 'ARRAY' ?
            @{$expressions} : $expressions
    ) {
        $code .= $expression;
        $code .= ";\n" unless $expression =~ /;$/;
    }
    $code .= 'return $_;';
    $code .= '}';
    ## no critic ProhibitStringyEva
    eval $code;
    ## use critic
    warn "unable to compile given expression into code $code, skipping"
        if $@;

    return $sub;
}

sub _bzme {
    my ($file) = @_;

    system("bzme -f -F $file >/dev/null 2>&1");
    $file =~ s/\.(?:tar\.gz|tgz|zip)$/.tar.bz2/;

    return $file;
}

sub _get_new_version {
    my ($line, $new_version) = @_;

    return unless $line =~ /^
                (
                        %define \s+              # macro
                                (?:
                                        version
                                |
                                        upstream_version
                                )
                |
                        (?i)Version:             # tag
                )
                (\s+)                        # spacing
                (\S+(?: \s+ \S+)*)           # value
        /ox;

    my ($directive, $spacing, $value) = ($1, $2, $3);

    if ($new_version) {
        $value = $new_version;
    }

    return ($directive, $spacing, $value);
}
sub _get_new_release {
    my ($line, $new_version, $new_release, $release_suffix) = @_;

    return unless $line =~ /^
        (
                %define \s+      # macro
                        (?:
                                rel
                        |
                                release
                        )
        |
                (?i)Release:     # tag
        )
        (\s+)                # spacing
        (\S+(?: \s+ \S+)*)   # value
        /ox;

    my ($directive, $spacing, $value) = ($1, $2, $3);

    if ($new_release) {
        $value = $new_release;
    } else {
        if ($value =~ /^% (\w+) (\s+) (\S+) $/x) {
            my ($macro_name, $macro_spacing, $macro_value) = ($1, $2, $3);
            $macro_value = _get_new_release_number($macro_value, $new_version, $release_suffix);
            $value = '%' . $macro_name . $macro_spacing . $macro_value;
        } elsif ($value =~ /^% { (\w+) (\s+) (\S+) } $/x) {
            my ($macro_name, $macro_spacing, $macro_value) = ($1, $2, $3);
            $macro_value = _get_new_release_number($macro_value, $new_version, $release_suffix);
            $value = '%{' . $macro_name . $macro_spacing . $macro_value . '}';
        } else {
            $value = _get_new_release_number($value, $new_version, $release_suffix);
        }
    }

    return ($directive, $spacing, $value);
}

sub _get_new_release_number {
    my ($value, $new_version, $release_suffix) = @_;

    my ($prefix, $number, $suffix); 
    if ($new_version) {
        $number = 1;
    } else {
        # optional suffix from configuration
        $release_suffix = $release_suffix ?
            quotemeta($release_suffix) : '';
        ($prefix, $number, $suffix) =
            $value =~ /^(.*?)(\d+)($release_suffix)?$/;

        croak "Unable to extract release number from value '$value'"
            unless $number;

        $number++;
    }

    return 
        ($prefix ? $prefix : "") .
        $number .
        ($suffix ? $suffix : "");

}

sub _fix_source {
    my ($source, $version) = @_;

    given ($source->{url}) {
        when (m!ftp.gnome.org/pub/GNOME/sources/!) {
            # the last part of the path should match current
            # major and minor version numbers:
            # ftp://ftp.gnome.org/pub/GNOME/sources/ORbit2/2.10/ORbit2-2.10.0.tar.bz2
            my ($major, $minor) = split('\.', $version);
            $source->{url} =~ m!(.+)/([^/]+)$!;
            my ($path, $file) = ($1, $2);
            if ($path =~ m!/(\d+)\.(\d+)$!) {
                # expected format found
                if ($1 != $major || $2 != $minor) {
                    # but not corresponding to the current version
                    $path =~ s!\d+\.\d+$!$major.$minor!;
                }
            } else {
                $path .= "/$major.$minor";
            }
            $source->{url} = "$path/$file";
        }
        when (m!\w+\.(perl|cpan)\.org/!) {
            # force http
            $source->{url} =~ s!ftp://ftp\.(perl|cpan)\.org/pub/CPAN!http://www.cpan.org!;
            # force .tar.gz
            $source->{bzme} = 1
                if $source->{url} =~ s!\.tar\.bz2$!.tar.gz!;
        }
        when (m!download.pear.php.net/!) {
            # PEAR: force tgz
            $source->{bzme} = 1
                if $source->{url} =~ s!\.tar\.bz2$!.tgz!;
        }
    }

    return $source;
}

sub _get_cpan_package_info {
    my ($name) = @_;

    my $agent = LWP::UserAgent->new();
    $agent->env_proxy();

    my $response = $agent->get(
        "http://cpanmetadb.appspot.com/v1.0/package/$name"
    ); 

    return unless $response->is_success();

    my $conf = YAML::AppConfig->new(
        string => $response->decoded_content()
    );

    return unless $conf->get('distfile');

    my $url =
        "http://search.cpan.org/CPAN/authors/id/" . $conf->get('distfile');
    my $version = $conf->get('version');

    return ($url, $version);
}

1;