imported initial version of youri svn

3 files changed, 860 insertions, 0 deletions

diff --git a/lib/Youri/Package/RPM.pm b/lib/Youri/Package/RPM.pm
new file mode 100644
index 0000000..cdb1680
--- /dev/null
+++ b/lib/Youri/Package/RPM.pm
@@ -0,0 +1,33 @@
+# $Id: /local/youri/soft/trunk/lib/Youri/Package/URPM.pm 2257 2006-07-05T09:22:47.088572Z guillaume  $
+package Youri::Package::RPM;
+
+=head1 NAME
+
+Youri::Package::RPM - Base class for all RPM-based package implementation
+
+=head1 DESCRIPTION
+
+This bases class factorize code between various RPM-based package
+implementation.
+
+=cut
+
+use strict;
+use warnings;
+use base 'Youri::Package';
+
+sub get_pattern {
+    my ($class, $name, $version, $release, $arch) = @_;
+
+    return 
+        ($name ? quotemeta($name) : '[\w-]+' ).
+        '-' .
+        ($version ? quotemeta($version) : '[^-]+' ).
+        '-' .
+        ($release ? quotemeta($release) : '[^-]+' ). 
+        '\.' .
+        ($arch ? quotemeta($arch) : '\w+' ).
+        '\.rpm';
+}
+
+1;
diff --git a/lib/Youri/Package/RPM4.pm b/lib/Youri/Package/RPM4.pm
new file mode 100644
index 0000000..5437a3d
--- /dev/null
+++ b/lib/Youri/Package/RPM4.pm
@@ -0,0 +1,429 @@
+# $Id: /local/youri/soft/trunk/lib/Youri/Package/URPM.pm 2129 2006-06-23T09:41:01.599329Z guillomovitch  $
+package Youri::Package::RPM4;
+
+=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 RPM4;
+use RPM4::Header;
+use RPM4::Sign;
+use File::Spec;
+use Scalar::Util qw/refaddr/;
+use base 'Youri::Package::RPM';
+use overload
+    '""'     => '_to_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('RPM4::Header');
+            $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};
+            $header = RPM4::Header->new($options{file});
+            croak "Can't get header from file $options{file}" if (!$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 RPM4::rpmvercmp($version1, $version2);
+}
+
+sub _depsense2flag {
+    my ($string) = @_;
+    my @flags = 0;
+    push(@flags, 'EQUAL') if ($string =~ /=/);
+    push(@flags, 'LESS') if ($string =~ /</);
+    push(@flags, 'GREATER') if ($string =~ />/);
+    return \@flags;
+}
+
+sub compare_ranges {
+    my ($class, $range1, $range2) = @_;
+    my @deps1 = split(/ /, $range1);
+    my @deps2 = split(/ /, $range2);
+    $deps1[1] = _depsense2flag($range1); 
+    $deps2[1] = _depsense2flag($range2); 
+    my $dep1 = RPM4::Header::Dependencies(
+        "PROVIDENAME",
+        \@deps1,
+    );
+    my $dep2 = RPM4::Header::Dependencies(
+        "PROVIDENAME",
+        \@deps2,
+    );
+
+    return $dep1->overlap($dep2);
+}
+
+sub get_name {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->tag('name');
+}
+
+sub get_version {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->tag('version');
+}
+
+sub get_release {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->tag('release');
+}
+
+sub get_revision_name {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return join('-', ($self->get_name, $self->get_version, $self->get_release));
+}
+
+sub get_full_name {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->queryformat('%{NAME}-%{VERSION}-%{RELEASE}.%|SOURCERPM?{%{ARCH}}:{src}|');
+}
+
+sub get_file_name {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->queryformat('%{NAME}-%{VERSION}-%{RELEASE}.%|SOURCERPM?{%{ARCH}}:{src}|.rpm');
+}
+
+sub get_arch {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->queryformat('%|SOURCERPM?{%{ARCH}}:{src}|');
+}
+
+sub get_url {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->tag('url');
+}
+
+sub get_summary {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->tag('summary');
+}
+
+sub get_description {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->tag('description');
+}
+
+sub get_packager {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->tag('packager');
+}
+
+sub get_file {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_file};
+}
+
+sub is_source {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->issrc();
+}
+
+sub is_binary {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return !$self->{_header}->issrc();
+}
+
+sub get_type {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return
+        $self->{_header}->issrc() ?
+        "source" :
+        "binary";
+}
+
+sub get_age {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->tag('buildtime');
+}
+
+sub get_source_package {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->tag('sourcerpm');
+}
+
+sub get_canonical_name {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    $self->{_header}->sourcerpmname() =~ /^(\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($tag);
+}
+
+
+sub _get_dependencies {
+    my ($self, $deptype) = @_;
+    my $deps = $self->{_header}->dep($deptype);
+    my @deps_list;
+    if ($deps) {
+    $deps->init();
+    while ($deps->next() >= 0) {
+        my @deps = $deps->info();
+        $deps[1] =~ m/^rpmlib\(/ and next; # skipping internal rpmlib dep
+        $deps[2] =~ s/^=$/==/; # rpm say foo = 1, not foo == 1, == come from URPM, which sucks
+        my $range = $deps[3] ? ($deps[2] . ' ' . $deps[3]) : undef;
+        push(@deps_list, [ $deps[1], $range ]);
+    }
+    }
+    @deps_list
+}
+
+sub get_requires {
+    my ($self) = @_;
+
+    return $self->_get_dependencies('REQUIRENAME');
+}
+
+sub get_provides {
+    my ($self) = @_;
+
+    return $self->_get_dependencies('PROVIDENAME');
+}
+
+sub get_obsoletes {
+    my ($self) = @_;
+   
+    return $self->_get_dependencies('OBSOLETENAME');
+}
+
+sub get_conflicts {
+    my ($self) = @_;
+
+    return $self->_get_dependencies('CONFLICTNAME');
+}
+
+sub get_files {
+    my ($self) = @_;
+
+    my $files = $self->{_header}->files();
+    my @fileslist;
+    if ($files) {
+        $files->init();
+        while ($files->next() >= 0) {
+            my $smode = $files->mode();
+            my $umode = 0;
+            foreach (0..15) { # converting unsigned to signed int :\
+                $umode |= $smode & (1 << $_);
+            }
+            push(@fileslist, [ $files->filename(), $umode, $files->md5() || '' ]);
+        }
+    }
+    @fileslist
+}
+
+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}->tag('changelogname');
+    my @time  = $self->{_header}->tag('changelogtime');
+    my @text  = $self->{_header}->tag('changelogtext');
+
+    my @changes;
+    foreach my $i (0 .. $#names) {
+        $changes[$i] = [
+            $names[$i],
+            $time[$i],
+            [
+                map { s/^.\s+//; $_ }
+                split(/\n/, $text[$i])
+            ]
+        ];
+    }
+
+    return @changes;
+}
+
+sub get_last_change {
+    my ($self) = @_;
+
+    return [
+        ($self->{_header}->tag('changelogname'))[0],
+        ($self->{_header}->tag('changelogtime'))[0],
+        [
+            map { s/^.\s+//; $_ }
+            split(/\n/, ($self->{_header}->tag('changelogtext'))[0])
+        ]
+    ];
+}
+
+sub _to_string {
+    return $_[0]->{_header}->fullname();
+}
+
+sub _to_number {
+    return refaddr($_[0]);
+}
+
+sub compare {
+    my ($self, $package) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->compare($package->{_header}) || 0;
+}
+
+sub sign {
+    my ($self, $name, $path, $passphrase) = @_;
+    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;
+
+    my $sign = RPM4::Sign->new(
+        name => $name,
+        path => $path,
+    );
+    $sign->{passphrase} = $passphrase;
+
+    $sign->rpmssign($self->{_file})
+}
+
+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;
diff --git a/lib/Youri/Package/URPM.pm b/lib/Youri/Package/URPM.pm
new file mode 100644
index 0000000..a01d52b
--- /dev/null
+++ b/lib/Youri/Package/URPM.pm
@@ -0,0 +1,398 @@
+# $Id: URPM.pm 955 2006-07-08 22:38:35Z nanardon $
+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
+    '""'     => '_to_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 compare_ranges {
+    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_name {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return join('-', ($self->{_header}->fullname())[0 .. 2]);
+}
+
+sub get_full_name {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_header}->fullname();
+}
+
+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 get_file {
+    my ($self) = @_;
+    croak "Not a class method" unless ref $self;
+
+    return $self->{_file};
+}
+
+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],
+            [
+                map { s/^.\s+//; $_ }
+                split(/\n/, $text[$i])
+            ]
+        ];
+    }
+
+    return @changes;
+}
+
+sub get_last_change {
+    my ($self) = @_;
+
+    return [
+        ($self->{_header}->changelog_name())[0],
+        ($self->{_header}->changelog_time())[0],
+        [
+            map { s/^.\s+//; $_ }
+            split(/\n/, ($self->{_header}->changelog_text())[0])
+        ]
+    ];
+}
+
+sub _to_string {
+    return $_[0]->{_header}->fullname();
+}
+
+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 sign {
+    my ($self, $name, $path, $passphrase) = @_;
+    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;
+
+    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;