path: root/lib/Youri/Package/URPM.pm

# $Id$
package Youri::Package::URPM;

=head1 NAME

Youri::Package::URPM - URPM-based rpm package implementation

=head1 DESCRIPTION

This is an URPM-based L<Youri::Package> implementation for rpm.

It is merely a wrapper over URPM::Package class, with a more structured
interface.

=cut

use strict;
use warnings;
use Carp;
use URPM;
use File::Spec;
use Expect;
use Scalar::Util qw/refaddr/;
use base 'Youri::Package::RPM';
use overload
    '""'     => 'as_string',
    '0+'     => '_to_number',
    fallback => 1;

=head1 CLASS METHODS

=head2 new(%args)

Creates and returns a new Youri::Package::URPM object.

Specific parameters:

=over

=item file $file

Path of file to use for creating this package.

=item header $header

L<URPM::Package> object to use for creating this package.

=back

=cut

sub _init {
    my ($self, %options) = @_;

    my $header;
    HEADER: {
        if (exists $options{header}) {
            croak "undefined header"
                unless $options{header};
            croak "invalid header"
                unless $options{header}->isa('URPM::Package');
            $header = $options{header};
            last HEADER;
        }

        if (exists $options{file}) {
            croak "undefined file"
                unless $options{file};
            croak "non-existing file $options{file}"
                unless -f $options{file};
            croak "non-readable file $options{file}"
                unless -r $options{file};
            my $urpm = URPM->new();
            $urpm->parse_rpm($options{file}, keep_all_tags => 1);
            $header = $urpm->{depslist}->[0];
            croak "non-rpm file $options{file}" unless $header;
            last HEADER;
        }

        croak "no way to extract header from arguments";
    }

    $self->{_header} = $header;
    $self->{_file}   = File::Spec->rel2abs($options{file});
}

sub compare_versions {
    my ($class, $version1, $version2) = @_;

    return URPM::rpmvercmp($version1, $version2);
}

sub check_ranges_compatibility {
    my ($class, $range1, $range2) = @_;

    return URPM::ranges_overlap($range1, $range2);
}

sub get_name {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->name();
}

sub get_version {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->version();
}

sub get_release {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->release();
}

sub get_revision {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->queryformat('%|EPOCH?{%{EPOCH}:}:{}|%{VERSION}-%{RELEASE}');
}

sub get_file_name {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->filename();
}

sub get_arch {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->arch();
}

sub get_url {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->url();
}

sub get_summary {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->summary();
}

sub get_description {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->description();
}

sub get_packager {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->packager();
}

sub is_source {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->arch() eq 'src';
}

sub is_binary {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->arch() ne 'src';
}

sub get_type {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return
        $self->{_header}->arch() eq 'src' ?
        "source" :
        "binary";
}

sub get_age {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->buildtime();
}

sub get_source_package {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->sourcerpm();
}

sub get_canonical_name {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    if ($self->{_header}->arch() eq 'src') {
       return $self->{_header}->name();
    } else {
       $self->{_header}->sourcerpm() =~ /^(\S+)-[^-]+-[^-]+\.src\.rpm$/;
       return $1;
    }
}

sub get_tag {
    my ($self, $tag) = @_;
    croak "Not a class method" unless ref $self;
    croak "invalid tag $tag" unless $self->{_header}->can($tag);
    return $self->{_header}->$tag();
}

sub get_requires {
    my ($self) = @_;

    return map {
        $_ =~ /^([^[]+)(?:\[\*\])?(?:\[(.+)\])?$/;
        [ $1, $2 ]
    } $self->{_header}->requires();
}

sub get_provides {
    my ($self) = @_;

    return map {
        $_ =~ /^([^[]+)(?:\[(.+)\])?$/;
        [ $1, $2 && $2 ne '*' ?  $2 : undef ]
    } $self->{_header}->provides();
}

sub get_obsoletes {
    my ($self) = @_;

    return map {
        $_ =~ /^([^[]+)(?:\[(.+)\])?$/;
        [ $1, $2 && $2 ne '*' ?  $2 : undef ]
    } $self->{_header}->obsoletes();
}

sub get_conflicts {
    my ($self) = @_;

    return $self->{_header}->conflicts();
}

sub get_files {
    my ($self) = @_;

    my @modes   = $self->{_header}->files_mode();
    my @md5sums = $self->{_header}->files_md5sum();

    return map {
        [ $_, shift @modes, shift @md5sums ]
    } $self->{_header}->files();
}

sub get_gpg_key {
    my ($self) = @_;
    
    my $signature = $self->{_header}->queryformat('%{SIGGPG:pgpsig}');
    
    return if $signature eq '(not a blob)';

    my $key_id = (split(/\s+/, $signature))[-1];

    return substr($key_id, 8);
}

sub get_information {
    my ($self) = @_;

    return $self->{_header}->queryformat(<<EOF);
Name        : %-27{NAME}  Relocations: %|PREFIXES?{[%{PREFIXES} ]}:{(not relocatable)}|
Version     : %-27{VERSION}       Vendor: %{VENDOR}
Release     : %-27{RELEASE}   Build Date: %{BUILDTIME:date}
Install Date: %|INSTALLTIME?{%-27{INSTALLTIME:date}}:{(not installed)         }|      Build Host: %{BUILDHOST}
Group       : %-27{GROUP}   Source RPM: %{SOURCERPM}
Size        : %-27{SIZE}%|LICENSE?{      License: %{LICENSE}}|
Signature   : %|DSAHEADER?{%{DSAHEADER:pgpsig}}:{%|RSAHEADER?{%{RSAHEADER:pgpsig}}:{%|SIGGPG?{%{SIGGPG:pgpsig}}:{%|SIGPGP?{%{SIGPGP:pgpsig}}:{(none)}|}|}|}|
%|PACKAGER?{Packager    : %{PACKAGER}\n}|%|URL?{URL         : %{URL}\n}|Summary     : %{SUMMARY}
Description :\n%{DESCRIPTION}
EOF
}

sub get_changes {
    my ($self) = @_;

    my @names = $self->{_header}->changelog_name();
    my @time  = $self->{_header}->changelog_time();
    my @text  = $self->{_header}->changelog_text();

    my @changes;
    foreach my $i (0 .. $#names) {
        $changes[$i] = [
            $names[$i],
            $time[$i],
            $text[$i],
        ];
    }

    return @changes;
}

sub get_last_change {
    my ($self) = @_;

    return [
        ($self->{_header}->changelog_name())[0],
        ($self->{_header}->changelog_time())[0],
        ($self->{_header}->changelog_text())[0],
    ];
}

sub as_string {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->fullname();
}

sub as_formated_string {
    my ($self, $format) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->queryformat($format);
}

sub _to_number {
    return refaddr($_[0]);
}

sub compare {
    my ($self, $package) = @_;
    croak "Not a class method" unless ref $self;

    return $self->{_header}->compare_pkg($package->{_header});
}

sub satisfy_range {
    my ($self, $range) = @_;
    croak "Not a class method" unless ref $self;

    return $self->check_ranges_compatibility("== " . $self->get_revision(), $range);
}

sub sign {
    my ($self, $name, $path, $passphrase, $target) = @_;
    croak "Not a class method" unless ref $self;

    # check if parent directory is writable
    my $parent = (File::Spec->splitpath($self->{_file}))[1];
    croak "Unsignable package, parent directory is read-only"
        unless -w $parent;
    
    # FIXME Will have to change that
    # we sign with cooker key even fro 2007.0 because this is for testing section
    return !system("sudo -H /root/bin/resign_cooker $self->{_file}");

    my $command =
        'LC_ALL=C rpm --resign ' . $self->{_file} .
        ' --define "_gpg_name ' . $name . '"' .
        ' --define "_gpg_path ' . $path . '"';
    my $expect = Expect->spawn($command) or die "Couldn't spawn command $command: $!\n";
    $expect->log_stdout(0);
    $expect->expect(20, -re => 'Enter pass phrase:');
    $expect->send("$passphrase\n");

    $expect->soft_close();
}

sub extract {
    my ($self) = @_;
    croak "Not a class method" unless ref $self;

    system("rpm2cpio $self->{_file} | cpio -id >/dev/null 2>&1");
}

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2002-2006, YOURI project

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut

1;